OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2017-11-08  Piotr Trojanek  <trojanek@adacore.com>

	* lib-xref.ads, lib-xref-spark_specific.adb
	(Traverse_Compilation_Unit): Move declaration to package body.

2017-11-08  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_spark.adb (Expand_SPARK_N_Object_Renaming_Declaration): Obtain
	the type of the renaming from its defining entity, rather then the
	subtype mark as there may not be a subtype mark.

2017-11-08  Jerome Lambourg  <lambourg@adacore.com>

	* adaint.c, s-oscons-tmplt.c, init.c, libgnat/system-qnx-aarch64.ads,
	libgnarl/a-intnam__qnx.ads, libgnarl/s-intman__qnx.adb,
	libgnarl/s-osinte__qnx.ads, libgnarl/s-qnx.ads,
	libgnarl/s-taprop__qnx.adb, s-oscons-tmplt.c, sigtramp-qnx.c,
	terminals.c: Initial port of GNAT for aarch64-qnx

2017-11-08  Elisa Barboni  <barboni@adacore.com>

	* exp_util.adb (Find_DIC_Type): Move...
	* sem_util.ads, sem_util.adb (Find_DIC_Type): ... here.

2017-11-08  Justin Squirek  <squirek@adacore.com>

	* sem_res.adb (Resolve_Allocator): Add info messages corresponding to
	the owner and corresponding coextension.

2017-11-08  Ed Schonberg  <schonberg@adacore.com>

	* sem_aggr.adb (Resolve_Delta_Aggregate): Divide into the
	following separate procedures.
	(Resolve_Delta_Array_Aggregate): Previous code form
	Resolve_Delta_Aggregate.
	(Resolve_Delta_Record_Aggregate): Extend previous code to cover latest
	ARG decisions on the legality rules for delta aggregates for records:
	in the case of a variant record, components from different variants
	cannot be specified in the delta aggregate, and this must be checked
	statically.

From-SVN: r254547
This commit is contained in:
Pierre-Marie de Rodat 2017-11-08 17:32:18 +00:00
parent 76b37a56d2
commit 8d9a1ba7bb
20 changed files with 3684 additions and 181 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
gcc/ada/ChangeLog
View File

@ -1,3 +1,44 @@
2017-11-08 Piotr Trojanek <trojanek@adacore.com>
* lib-xref.ads, lib-xref-spark_specific.adb
(Traverse_Compilation_Unit): Move declaration to package body.
2017-11-08 Hristian Kirtchev <kirtchev@adacore.com>
* exp_spark.adb (Expand_SPARK_N_Object_Renaming_Declaration): Obtain
the type of the renaming from its defining entity, rather then the
subtype mark as there may not be a subtype mark.
2017-11-08 Jerome Lambourg <lambourg@adacore.com>
* adaint.c, s-oscons-tmplt.c, init.c, libgnat/system-qnx-aarch64.ads,
libgnarl/a-intnam__qnx.ads, libgnarl/s-intman__qnx.adb,
libgnarl/s-osinte__qnx.ads, libgnarl/s-qnx.ads,
libgnarl/s-taprop__qnx.adb, s-oscons-tmplt.c, sigtramp-qnx.c,
terminals.c: Initial port of GNAT for aarch64-qnx
2017-11-08 Elisa Barboni <barboni@adacore.com>
* exp_util.adb (Find_DIC_Type): Move...
* sem_util.ads, sem_util.adb (Find_DIC_Type): ... here.
2017-11-08 Justin Squirek <squirek@adacore.com>
* sem_res.adb (Resolve_Allocator): Add info messages corresponding to
the owner and corresponding coextension.
2017-11-08 Ed Schonberg <schonberg@adacore.com>
* sem_aggr.adb (Resolve_Delta_Aggregate): Divide into the
following separate procedures.
(Resolve_Delta_Array_Aggregate): Previous code form
Resolve_Delta_Aggregate.
(Resolve_Delta_Record_Aggregate): Extend previous code to cover latest
ARG decisions on the legality rules for delta aggregates for records:
in the case of a variant record, components from different variants
cannot be specified in the delta aggregate, and this must be checked
statically.
2017-11-08 Piotr Trojanek <trojanek@adacore.com>
* spark_xrefs.ads (SPARK_Scope_Record): Remove File_Num component.

4
gcc/ada/adaint.c
View File

@ -1012,7 +1012,7 @@ __gnat_open_new_temp (char *path, int fmode)
#if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \
|| defined (__linux__) || defined (__GLIBC__) || defined (__ANDROID__) \
|| defined (__DragonFly__)) && !defined (__vxworks)
|| defined (__DragonFly__) || defined (__QNX__)) && !defined (__vxworks)
return mkstemp (path);
#elif defined (__Lynx__)
mktemp (path);
@ -1185,7 +1185,7 @@ __gnat_tmp_name (char *tmp_filename)
#elif defined (__linux__) || defined (__FreeBSD__) || defined (__NetBSD__) \
|| defined (__OpenBSD__) || defined (__GLIBC__) || defined (__ANDROID__) \
|| defined (__DragonFly__)
|| defined (__DragonFly__) || defined (__QNX__)
#define MAX_SAFE_PATH 1000
char *tmpdir = getenv ("TMPDIR");

2
gcc/ada/exp_spark.adb
View File

@ -349,7 +349,7 @@ package body Exp_SPARK is
Loc : constant Source_Ptr := Sloc (N);
Obj_Id : constant Entity_Id := Defining_Entity (N);
Nam : constant Node_Id := Name (N);
Typ : constant Entity_Id := Etype (Subtype_Mark (N));
Typ : constant Entity_Id := Etype (Obj_Id);
begin
-- Transform a renaming of the form

65
gcc/ada/exp_util.adb
View File

@ -165,11 +165,6 @@ package body Exp_Util is
-- Force evaluation of bounds of a slice, which may be given by a range
-- or by a subtype indication with or without a constraint.
function Find_DIC_Type (Typ : Entity_Id) return Entity_Id;
-- Subsidiary to all Build_DIC_Procedure_xxx routines. Find the type which
-- defines the Default_Initial_Condition pragma of type Typ. This is either
-- Typ itself or a parent type when the pragma is inherited.
function Make_CW_Equivalent_Type
(T : Entity_Id;
E : Node_Id) return Entity_Id;
@ -5389,66 +5384,6 @@ package body Exp_Util is
return TSS (Utyp, TSS_Finalize_Address);
end Finalize_Address;
-------------------
-- Find_DIC_Type --
-------------------
function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is
Curr_Typ : Entity_Id;
-- The current type being examined in the parent hierarchy traversal
DIC_Typ : Entity_Id;
-- The type which carries the DIC pragma. This variable denotes the
-- partial view when private types are involved.
Par_Typ : Entity_Id;
-- The parent type of the current type. This variable denotes the full
-- view when private types are involved.
begin
-- The input type defines its own DIC pragma, therefore it is the owner
if Has_Own_DIC (Typ) then
DIC_Typ := Typ;
-- Otherwise the DIC pragma is inherited from a parent type
else
pragma Assert (Has_Inherited_DIC (Typ));
-- Climb the parent chain
Curr_Typ := Typ;
loop
-- Inspect the parent type. Do not consider subtypes as they
-- inherit the DIC attributes from their base types.
DIC_Typ := Base_Type (Etype (Curr_Typ));
-- Look at the full view of a private type because the type may
-- have a hidden parent introduced in the full view.
Par_Typ := DIC_Typ;
if Is_Private_Type (Par_Typ)
and then Present (Full_View (Par_Typ))
then
Par_Typ := Full_View (Par_Typ);
end if;
-- Stop the climb once the nearest parent type which defines a DIC
-- pragma of its own is encountered or when the root of the parent
-- chain is reached.
exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ;
Curr_Typ := Par_Typ;
end loop;
end if;
return DIC_Typ;
end Find_DIC_Type;
------------------------
-- Find_Interface_ADT --
------------------------

100
gcc/ada/init.c
View File

@ -2516,6 +2516,104 @@ __gnat_install_handler (void)
__gnat_handler_installed = 1;
}
#elif defined(__QNX__)
/***************/
/* QNX Section */
/***************/
#include <signal.h>
#include <unistd.h>
#include <string.h>
#include "sigtramp.h"
void
__gnat_map_signal (int sig,
siginfo_t *si ATTRIBUTE_UNUSED,
void *mcontext ATTRIBUTE_UNUSED)
{
struct Exception_Data *exception;
const char *msg;
switch(sig)
{
case SIGFPE:
exception = &constraint_error;
msg = "SIGFPE";
break;
case SIGILL:
exception = &constraint_error;
msg = "SIGILL";
break;
case SIGSEGV:
exception = &storage_error;
msg = "stack overflow or erroneous memory access";
break;
case SIGBUS:
exception = &constraint_error;
msg = "SIGBUS";
break;
default:
exception = &program_error;
msg = "unhandled signal";
}
Raise_From_Signal_Handler (exception, msg);
}
static void
__gnat_error_handler (int sig, siginfo_t *si, void *ucontext)
{
__gnat_sigtramp (sig, (void *) si, (void *) ucontext,
(__sigtramphandler_t *)&__gnat_map_signal);
}
void
__gnat_install_handler (void)
{
struct sigaction act;
int err;
act.sa_handler = __gnat_error_handler;
act.sa_flags = SA_NODEFER | SA_SIGINFO;
sigemptyset (&act.sa_mask);
/* Do not install handlers if interrupt state is "System" */
if (__gnat_get_interrupt_state (SIGFPE) != 's') {
err = sigaction (SIGFPE, &act, NULL);
if (err == -1) {
err = errno;
perror ("error while attaching SIGFPE");
perror (strerror (err));
}
}
if (__gnat_get_interrupt_state (SIGILL) != 's') {
sigaction (SIGILL, &act, NULL);
if (err == -1) {
err = errno;
perror ("error while attaching SIGFPE");
perror (strerror (err));
}
}
if (__gnat_get_interrupt_state (SIGSEGV) != 's') {
sigaction (SIGSEGV, &act, NULL);
if (err == -1) {
err = errno;
perror ("error while attaching SIGFPE");
perror (strerror (err));
}
}
if (__gnat_get_interrupt_state (SIGBUS) != 's') {
sigaction (SIGBUS, &act, NULL);
if (err == -1) {
err = errno;
perror ("error while attaching SIGFPE");
perror (strerror (err));
}
}
__gnat_handler_installed = 1;
}
#elif defined (__DJGPP__)
void
@ -2648,7 +2746,7 @@ __gnat_install_handler (void)
#if defined (_WIN32) || defined (__INTERIX) \
|| defined (__Lynx__) || defined(__NetBSD__) || defined(__FreeBSD__) \
|| defined (__OpenBSD__) || defined (__DragonFly__)
|| defined (__OpenBSD__) || defined (__DragonFly__) || defined(__QNX__)
#define HAVE_GNAT_INIT_FLOAT

6
gcc/ada/lib-xref-spark_specific.adb
View File

@ -96,6 +96,12 @@ package body SPARK_Specific is
function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range;
-- Hash function for hash table
generic
with procedure Process (N : Node_Id) is <>;
procedure Traverse_Compilation_Unit (CU : Node_Id);
-- Call Process on all declarations within compilation unit CU. Bodies
-- of stubs are also traversed, but generic declarations are ignored.
--------------------
-- Add_SPARK_File --
--------------------

6
gcc/ada/lib-xref.ads
View File

@ -645,12 +645,6 @@ package Lib.Xref is
-- files and scopes) and from shared cross-references. Fill in the
-- tables in library package called SPARK_Xrefs.
generic
with procedure Process (N : Node_Id) is <>;
procedure Traverse_Compilation_Unit (CU : Node_Id);
-- Call Process on all declarations within compilation unit CU. Bodies
-- of stubs are also traversed, but generic declarations are ignored.
end SPARK_Specific;
-----------------

146
gcc/ada/libgnarl/a-intnam__qnx.ads Normal file
View File

@ -0,0 +1,146 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- A D A . I N T E R R U P T S . N A M E S --
-- --
-- S p e c --
-- --
-- Copyright (C) 1991-2017, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a QNX version of this package
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
-- SIGINT: made available for Ada handler
-- This target-dependent package spec contains names of interrupts
-- supported by the local system.
with System.OS_Interface;
package Ada.Interrupts.Names is
-- All identifiers in this unit are implementation defined
pragma Implementation_Defined;
-- Beware that the mapping of names to signals may be many-to-one. There
-- may be aliases. Also, for all signal names that are not supported on the
-- current system the value of the corresponding constant will be zero.
SIGHUP : constant Interrupt_ID :=
System.OS_Interface.SIGHUP; -- hangup
SIGINT : constant Interrupt_ID :=
System.OS_Interface.SIGINT; -- interrupt (rubout)
SIGQUIT : constant Interrupt_ID :=
System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
SIGILL : constant Interrupt_ID :=
System.OS_Interface.SIGILL; -- illegal instruction (not reset)
SIGTRAP : constant Interrupt_ID :=
System.OS_Interface.SIGTRAP; -- trace trap (not reset)
SIGIOT : constant Interrupt_ID :=
System.OS_Interface.SIGIOT; -- IOT instruction
SIGABRT : constant Interrupt_ID := -- used by abort,
System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
SIGFPE : constant Interrupt_ID :=
System.OS_Interface.SIGFPE; -- floating point exception
SIGKILL : constant Interrupt_ID :=
System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
SIGBUS : constant Interrupt_ID :=
System.OS_Interface.SIGBUS; -- bus error
SIGSEGV : constant Interrupt_ID :=
System.OS_Interface.SIGSEGV; -- segmentation violation
SIGPIPE : constant Interrupt_ID := -- write on a pipe with
System.OS_Interface.SIGPIPE; -- no one to read it
SIGALRM : constant Interrupt_ID :=
System.OS_Interface.SIGALRM; -- alarm clock
SIGTERM : constant Interrupt_ID :=
System.OS_Interface.SIGTERM; -- software termination signal from kill
SIGUSR1 : constant Interrupt_ID :=
System.OS_Interface.SIGUSR1; -- user defined signal 1
SIGUSR2 : constant Interrupt_ID :=
System.OS_Interface.SIGUSR2; -- user defined signal 2
SIGCLD : constant Interrupt_ID :=
System.OS_Interface.SIGCLD; -- child status change
SIGCHLD : constant Interrupt_ID :=
System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
SIGWINCH : constant Interrupt_ID :=
System.OS_Interface.SIGWINCH; -- window size change
SIGURG : constant Interrupt_ID :=
System.OS_Interface.SIGURG; -- urgent condition on IO channel
SIGPOLL : constant Interrupt_ID :=
System.OS_Interface.SIGPOLL; -- pollable event occurred
SIGIO : constant Interrupt_ID := -- input/output possible,
System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
SIGSTOP : constant Interrupt_ID :=
System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
SIGTSTP : constant Interrupt_ID :=
System.OS_Interface.SIGTSTP; -- user stop requested from tty
SIGCONT : constant Interrupt_ID :=
System.OS_Interface.SIGCONT; -- stopped process has been continued
SIGTTIN : constant Interrupt_ID :=
System.OS_Interface.SIGTTIN; -- background tty read attempted
SIGTTOU : constant Interrupt_ID :=
System.OS_Interface.SIGTTOU; -- background tty write attempted
SIGVTALRM : constant Interrupt_ID :=
System.OS_Interface.SIGVTALRM; -- virtual timer expired
SIGPROF : constant Interrupt_ID :=
System.OS_Interface.SIGPROF; -- profiling timer expired
SIGXCPU : constant Interrupt_ID :=
System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
SIGXFSZ : constant Interrupt_ID :=
System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
end Ada.Interrupts.Names;

298
gcc/ada/libgnarl/s-intman__qnx.adb Normal file
View File

@ -0,0 +1,298 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2017, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the QNX/Neutrino threads version of this package
-- Make a careful study of all signals available under the OS, to see which
-- need to be reserved, kept always unmasked, or kept always unmasked. Be on
-- the lookout for special signals that may be used by the thread library.
-- Since this is a multi target file, the signal <-> exception mapping
-- is simple minded. If you need a more precise and target specific
-- signal handling, create a new s-intman.adb that will fit your needs.
-- This file assumes that:
-- SIGFPE, SIGILL, SIGSEGV and SIGBUS exist. They are mapped as follows:
-- SIGPFE => Constraint_Error
-- SIGILL => Program_Error
-- SIGSEGV => Storage_Error
-- SIGBUS => Storage_Error
-- SIGINT exists and will be kept unmasked unless the pragma
-- Unreserve_All_Interrupts is specified anywhere in the application.
-- System.OS_Interface contains the following:
-- SIGADAABORT: the signal that will be used to abort tasks.
-- Unmasked: the OS specific set of signals that should be unmasked in
-- all the threads. SIGADAABORT is unmasked by
-- default
-- Reserved: the OS specific set of signals that are reserved.
with System.Task_Primitives;
package body System.Interrupt_Management is
use Interfaces.C;
use System.OS_Interface;
type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
Exception_Interrupts : constant Interrupt_List :=
(SIGFPE, SIGILL, SIGSEGV, SIGBUS);
Unreserve_All_Interrupts : Interfaces.C.int;
pragma Import
(C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
-----------------------
-- Local Subprograms --
-----------------------
procedure Signal_Trampoline
(signo : Signal;
siginfo : System.Address;
ucontext : System.Address;
handler : System.Address);
pragma Import (C, Signal_Trampoline, "__gnat_sigtramp");
-- Pass the real handler to a speical function that handles unwinding by
-- skipping over the kernel signal frame (which doesn't contain any unwind
-- information).
procedure Map_Signal
(signo : Signal;
siginfo : System.Address;
ucontext : System.Address);
pragma Import (C, Map_Signal, "__gnat_map_signal");
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in init.c The input argument is the
-- interrupt number, and the result is one of the following:
User : constant Character := 'u';
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
-- 'u' Interrupt_State pragma set state to User
-- 'r' Interrupt_State pragma set state to Runtime
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
procedure Notify_Exception
(signo : Signal;
siginfo : System.Address;
ucontext : System.Address);
-- This function identifies the Ada exception to be raised using the
-- information when the system received a synchronous signal. Since this
-- function is machine and OS dependent, different code has to be provided
-- for different target.
----------------------
-- Notify_Exception --
----------------------
Signal_Mask : aliased sigset_t;
-- The set of signals handled by Notify_Exception
procedure Notify_Exception
(signo : Signal;
siginfo : System.Address;
ucontext : System.Address)
is
Result : Interfaces.C.int;
begin
-- With the __builtin_longjmp, the signal mask is not restored, so we
-- need to restore it explicitly.
Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
pragma Assert (Result = 0);
-- Perform the necessary context adjustments prior to a raise
-- from a signal handler.
Adjust_Context_For_Raise (signo, ucontext);
-- Check that treatment of exception propagation here is consistent with
-- treatment of the abort signal in System.Task_Primitives.Operations.
Signal_Trampoline (signo, siginfo, ucontext, Map_Signal'Address);
end Notify_Exception;
----------------
-- Initialize --
----------------
Initialized : Boolean := False;
procedure Initialize is
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
Result : System.OS_Interface.int;
Use_Alternate_Stack : constant Boolean :=
System.Task_Primitives.Alternate_Stack_Size /= 0;
-- Whether to use an alternate signal stack for stack overflows
begin
if Initialized then
return;
end if;
Initialized := True;
-- Need to call pthread_init very early because it is doing signal
-- initializations.
pthread_init;
Abort_Task_Interrupt := SIGADAABORT;
act.sa_handler := Notify_Exception'Address;
-- Setting SA_SIGINFO asks the kernel to pass more than just the signal
-- number argument to the handler when it is called. The set of extra
-- parameters includes a pointer to the interrupted context, which the
-- ZCX propagation scheme needs.
-- Most man pages for sigaction mention that sa_sigaction should be set
-- instead of sa_handler when SA_SIGINFO is on. In practice, the two
-- fields are actually union'ed and located at the same offset.
-- On some targets, we set sa_flags to SA_NODEFER so that during the
-- handler execution we do not change the Signal_Mask to be masked for
-- the Signal.
-- This is a temporary fix to the problem that the Signal_Mask is not
-- restored after the exception (longjmp) from the handler. The right
-- fix should be made in sigsetjmp so that we save the Signal_Set and
-- restore it after a longjmp.
-- Since SA_NODEFER is obsolete, instead we reset explicitly the mask
-- in the exception handler.
Result := sigemptyset (Signal_Mask'Access);
pragma Assert (Result = 0);
-- Add signals that map to Ada exceptions to the mask
for J in Exception_Interrupts'Range loop
if State (Exception_Interrupts (J)) /= Default then
Result :=
sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
pragma Assert (Result = 0);
end if;
end loop;
act.sa_mask := Signal_Mask;
pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
pragma Assert (Reserve = (Interrupt_ID'Range => False));
-- Process state of exception signals
for J in Exception_Interrupts'Range loop
if State (Exception_Interrupts (J)) /= User then
Keep_Unmasked (Exception_Interrupts (J)) := True;
Reserve (Exception_Interrupts (J)) := True;
if State (Exception_Interrupts (J)) /= Default then
act.sa_flags := SA_SIGINFO;
if Use_Alternate_Stack
and then Exception_Interrupts (J) = SIGSEGV
then
act.sa_flags := act.sa_flags + SA_ONSTACK;
end if;
Result :=
sigaction
(Signal (Exception_Interrupts (J)), act'Unchecked_Access,
old_act'Unchecked_Access);
pragma Assert (Result = 0);
end if;
end if;
end loop;
if State (Abort_Task_Interrupt) /= User then
Keep_Unmasked (Abort_Task_Interrupt) := True;
Reserve (Abort_Task_Interrupt) := True;
end if;
-- Set SIGINT to unmasked state as long as it is not in "User" state.
-- Check for Unreserve_All_Interrupts last.
if State (SIGINT) /= User then
Keep_Unmasked (SIGINT) := True;
Reserve (SIGINT) := True;
end if;
-- Check all signals for state that requires keeping them unmasked and
-- reserved.
for J in Interrupt_ID'Range loop
if State (J) = Default or else State (J) = Runtime then
Keep_Unmasked (J) := True;
Reserve (J) := True;
end if;
end loop;
-- Add the set of signals that must always be unmasked for this target
for J in Unmasked'Range loop
Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
Reserve (Interrupt_ID (Unmasked (J))) := True;
end loop;
-- Add target-specific reserved signals
if Reserved'Length > 0 then
for J in Reserved'Range loop
Reserve (Interrupt_ID (Reserved (J))) := True;
end loop;
end if;
-- Process pragma Unreserve_All_Interrupts. This overrides any settings
-- due to pragma Interrupt_State:
if Unreserve_All_Interrupts /= 0 then
Keep_Unmasked (SIGINT) := False;
Reserve (SIGINT) := False;
end if;
-- We do not really have Signal 0. We just use this value to identify
-- non-existent signals (see s-intnam.ads). Therefore, Signal should not
-- be used in all signal related operations hence mark it as reserved.
Reserve (0) := True;
end Initialize;
end System.Interrupt_Management;

619
gcc/ada/libgnarl/s-osinte__qnx.ads Normal file
View File

@ -0,0 +1,619 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . O S _ I N T E R F A C E --
-- --
-- S p e c --
-- --
-- Copyright (C) 1995-2017, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a QNX/Neutrino version of this package
-- This package encapsulates all direct interfaces to OS services
-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Ada.Unchecked_Conversion;
with Interfaces.C;
with System.OS_Constants;
package System.OS_Interface is
pragma Preelaborate;
subtype int is Interfaces.C.int;
subtype char is Interfaces.C.char;
subtype short is Interfaces.C.short;
subtype long is Interfaces.C.long;
subtype unsigned is Interfaces.C.unsigned;
subtype unsigned_short is Interfaces.C.unsigned_short;
subtype unsigned_long is Interfaces.C.unsigned_long;
subtype unsigned_char is Interfaces.C.unsigned_char;
subtype plain_char is Interfaces.C.plain_char;
subtype size_t is Interfaces.C.size_t;
-----------
-- Errno --
-----------
function errno return int;
pragma Import (C, errno, "__get_errno");
EPERM : constant := 1;
EINTR : constant := 4;
EAGAIN : constant := 11;
ENOMEM : constant := 12;
EINVAL : constant := 22;
ETIMEDOUT : constant := 260;
-------------
-- Signals --
-------------
Max_Interrupt : constant := 64;
type Signal is new int range 0 .. Max_Interrupt;
for Signal'Size use int'Size;
SIGHUP : constant := 1;
SIGINT : constant := 2;
SIGQUIT : constant := 3;
SIGILL : constant := 4;
SIGTRAP : constant := 5;
SIGIOT : constant := 6;
SIGABRT : constant := 6;
SIGDEADLK : constant := 7;
SIGFPE : constant := 8;
SIGKILL : constant := 9;
SIGBUS : constant := 10;
SIGSEGV : constant := 11;
SIGSYS : constant := 12;
SIGPIPE : constant := 13;
SIGALRM : constant := 14;
SIGTERM : constant := 15;
SIGUSR1 : constant := 16;
SIGUSR2 : constant := 17;
SIGCLD : constant := 18;
SIGCHLD : constant := 18;
SIGPWR : constant := 19;
SIGWINCH : constant := 20;
SIGURG : constant := 21;
SIGPOLL : constant := 22;
SIGIO : constant := 22;
SIGSTOP : constant := 23;
SIGTSTP : constant := 24;
SIGCONT : constant := 25;
SIGTTIN : constant := 26;
SIGTTOU : constant := 27;
SIGVTALRM : constant := 28;
SIGPROF : constant := 29;
SIGXCPU : constant := 30;
SIGXFSZ : constant := 31;
SIGRTMIN : constant := 41;
SITRTMAX : constant := 56;
SIGSELECT : constant := 57;
SIGPHOTON : constant := 58;
SIGADAABORT : constant := SIGABRT;
-- Change this to use another signal for task abort. SIGTERM might be a
-- good one.
type Signal_Set is array (Natural range <>) of Signal;
Unmasked : constant Signal_Set := (
SIGTRAP,
-- To enable debugging on multithreaded applications, mark SIGTRAP to
-- be kept unmasked.
SIGBUS,
SIGTTIN, SIGTTOU, SIGTSTP,
-- Keep these three signals unmasked so that background processes and IO
-- behaves as normal "C" applications
SIGPROF,
-- To avoid confusing the profiler
SIGKILL, SIGSTOP);
-- These two signals actually can't be masked (POSIX won't allow it)
Reserved : constant Signal_Set := (SIGKILL, SIGSTOP, SIGSEGV);
type sigset_t is private;
function sigaddset (set : access sigset_t; sig : Signal) return int;
pragma Import (C, sigaddset, "sigaddset");
function sigdelset (set : access sigset_t; sig : Signal) return int;
pragma Import (C, sigdelset, "sigdelset");
function sigfillset (set : access sigset_t) return int;
pragma Import (C, sigfillset, "sigfillset");
function sigismember (set : access sigset_t; sig : Signal) return int;
pragma Import (C, sigismember, "sigismember");
function sigemptyset (set : access sigset_t) return int;
pragma Import (C, sigemptyset, "sigemptyset");
type union_type_3 is new String (1 .. 116);
type siginfo_t is record
si_signo : int;
si_code : int;
si_errno : int;
X_data : union_type_3;
end record;
pragma Convention (C, siginfo_t);
type struct_sigaction is record
sa_handler : System.Address;
sa_flags : Interfaces.C.int;
sa_mask : sigset_t;
end record;
pragma Convention (C, struct_sigaction);
type struct_sigaction_ptr is access all struct_sigaction;
SIG_BLOCK : constant := 0;
SIG_UNBLOCK : constant := 1;
SIG_SETMASK : constant := 2;
SIG_PENDING : constant := 5;
SA_NOCLDSTOP : constant := 16#0001#;
SA_SIGINFO : constant := 16#0002#;
SA_RESETHAND : constant := 16#0004#;
SA_ONSTACK : constant := 16#0008#;
SA_NODEFER : constant := 16#0010#;
SA_NOCLDWAIT : constant := 16#0020#;
SS_ONSTACK : constant := 1;
SS_DISABLE : constant := 2;
SIG_DFL : constant := 0;
SIG_IGN : constant := 1;
function sigaction
(sig : Signal;
act : struct_sigaction_ptr;
oact : struct_sigaction_ptr) return int;
pragma Import (C, sigaction, "sigaction");
----------
-- Time --
----------
Time_Slice_Supported : constant Boolean := True;
-- Indicates whether time slicing is supported
type timespec is private;
type clockid_t is new int;
function clock_gettime
(clock_id : clockid_t; tp : access timespec) return int;
pragma Import (C, clock_gettime, "clock_gettime");
function clock_getres
(clock_id : clockid_t;
res : access timespec) return int;
pragma Import (C, clock_getres, "clock_getres");
function To_Duration (TS : timespec) return Duration;
pragma Inline (To_Duration);
function To_Timespec (D : Duration) return timespec;
pragma Inline (To_Timespec);
function sysconf (name : int) return long;
pragma Import (C, sysconf);
SC_CLK_TCK : constant := 2;
SC_NPROCESSORS_ONLN : constant := 84;
-------------------------
-- Priority Scheduling --
-------------------------
SCHED_OTHER : constant := 0;
SCHED_FIFO : constant := 1;
SCHED_RR : constant := 2;
function To_Target_Priority
(Prio : System.Any_Priority) return Interfaces.C.int
with Inline_Always;
-- Maps System.Any_Priority to a POSIX priority
-------------
-- Process --
-------------
type pid_t is private;
function kill (pid : pid_t; sig : Signal) return int;
pragma Import (C, kill, "kill");
function getpid return pid_t;
pragma Import (C, getpid, "getpid");
-------------
-- Threads --
-------------
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
type pthread_t is new unsigned_long;
subtype Thread_Id is pthread_t;
function To_pthread_t is
new Ada.Unchecked_Conversion (unsigned_long, pthread_t);
type pthread_mutex_t is limited private;
type pthread_cond_t is limited private;
type pthread_attr_t is limited private;
type pthread_mutexattr_t is limited private;
type pthread_condattr_t is limited private;
type pthread_key_t is private;
PTHREAD_CREATE_DETACHED : constant := 1;
PTHREAD_SCOPE_PROCESS : constant := 1;
PTHREAD_SCOPE_SYSTEM : constant := 0;
-- Read/Write lock not supported on Android.
subtype pthread_rwlock_t is pthread_mutex_t;
subtype pthread_rwlockattr_t is pthread_mutexattr_t;
-----------
-- Stack --
-----------
type stack_t is record
ss_sp : System.Address;
ss_flags : int;
ss_size : size_t;
end record;
pragma Convention (C, stack_t);
function sigaltstack
(ss : not null access stack_t;
oss : access stack_t) return int;
pragma Import (C, sigaltstack, "sigaltstack");
Alternate_Stack : aliased System.Address;
-- Dummy definition: alternate stack not available due to missing
-- sigaltstack
Alternate_Stack_Size : constant := 0;
-- This must be in keeping with init.c:__gnat_alternate_stack
Stack_Base_Available : constant Boolean := False;
-- Indicates whether the stack base is available on this target
function Get_Stack_Base (thread : pthread_t) return System.Address
with Inline_Always;
-- This is a dummy procedure to share some GNULLI files
function Get_Page_Size return int;
pragma Import (C, Get_Page_Size, "getpagesize");
-- Returns the size of a page
PROT_NONE : constant := 0;
PROT_READ : constant := 1;
PROT_WRITE : constant := 2;
PROT_EXEC : constant := 4;
PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
PROT_ON : constant := PROT_READ;
PROT_OFF : constant := PROT_ALL;
function mprotect (addr : Address; len : size_t; prot : int) return int;
pragma Import (C, mprotect);
---------------------------------------
-- Nonstandard Thread Initialization --
---------------------------------------
procedure pthread_init with Inline_Always;
-------------------------
-- POSIX.1c Section 3 --
-------------------------
function sigwait (set : access sigset_t; sig : access Signal) return int;
pragma Import (C, sigwait, "sigwait");
function pthread_kill (thread : pthread_t; sig : Signal) return int;
pragma Import (C, pthread_kill, "pthread_kill");
function pthread_sigmask
(how : int;
set : access sigset_t;
oset : access sigset_t) return int;
pragma Import (C, pthread_sigmask, "sigprocmask");
-- pthread_sigmask maybe be broken due to mismatch between sigset_t and
-- kernel_sigset_t, substitute sigprocmask temporarily. ???
-- pragma Import (C, pthread_sigmask, "pthread_sigmask");
--------------------------
-- POSIX.1c Section 11 --
--------------------------
function pthread_mutexattr_init
(attr : access pthread_mutexattr_t) return int;
pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
function pthread_mutexattr_destroy
(attr : access pthread_mutexattr_t) return int;
pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
function pthread_mutex_init
(mutex : access pthread_mutex_t;
attr : access pthread_mutexattr_t) return int;
pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
function pthread_condattr_init
(attr : access pthread_condattr_t) return int;
pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
function pthread_condattr_destroy
(attr : access pthread_condattr_t) return int;
pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
function pthread_cond_init
(cond : access pthread_cond_t;
attr : access pthread_condattr_t) return int;
pragma Import (C, pthread_cond_init, "pthread_cond_init");
function pthread_cond_destroy (cond : access pthread_cond_t) return int;
pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
function pthread_cond_signal (cond : access pthread_cond_t) return int;
pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
function pthread_cond_wait
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
function pthread_cond_timedwait
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t;
abstime : access timespec) return int;
pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
Relative_Timed_Wait : constant Boolean := False;
-- pthread_cond_timedwait requires an absolute delay time
--------------------------
-- POSIX.1c Section 13 --
--------------------------
PTHREAD_PRIO_PROTECT : constant := 0;
PTHREAD_PRIO_INHERIT : constant := 1;
function pthread_mutexattr_setprotocol
(attr : access pthread_mutexattr_t;
protocol : int) return int is (0);
function pthread_mutexattr_setprioceiling
(attr : access pthread_mutexattr_t;
prioceiling : int) return int is (0);
type struct_sched_param is record
sched_priority : int; -- scheduling priority
end record;
pragma Convention (C, struct_sched_param);
function pthread_setschedparam
(thread : pthread_t;
policy : int;
param : access struct_sched_param) return int;
pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
function pthread_attr_setscope
(attr : access pthread_attr_t;
scope : int) return int;
pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
function pthread_attr_setschedpolicy
(attr : access pthread_attr_t;
policy : int) return int;
pragma Import
(C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy");
function sched_yield return int;
pragma Import (C, sched_yield, "sched_yield");
---------------------------
-- P1003.1c - Section 16 --
---------------------------
function pthread_attr_init
(attributes : access pthread_attr_t) return int;
pragma Import (C, pthread_attr_init, "pthread_attr_init");
function pthread_attr_destroy
(attributes : access pthread_attr_t) return int;
pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
function pthread_attr_setdetachstate
(attr : access pthread_attr_t;
detachstate : int) return int;
pragma Import
(C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
function pthread_attr_setstacksize
(attr : access pthread_attr_t;
stacksize : size_t) return int;
pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
function pthread_create
(thread : access pthread_t;
attributes : access pthread_attr_t;
start_routine : Thread_Body;
arg : System.Address) return int;
pragma Import (C, pthread_create, "pthread_create");
procedure pthread_exit (status : System.Address);
pragma Import (C, pthread_exit, "pthread_exit");
function pthread_self return pthread_t;
pragma Import (C, pthread_self, "pthread_self");
function lwp_self return System.Address;
pragma Import (C, lwp_self, "pthread_self");
--------------------------
-- POSIX.1c Section 17 --
--------------------------
function pthread_setspecific
(key : pthread_key_t;
value : System.Address) return int;
pragma Import (C, pthread_setspecific, "pthread_setspecific");
function pthread_getspecific (key : pthread_key_t) return System.Address;
pragma Import (C, pthread_getspecific, "pthread_getspecific");
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function pthread_key_create
(key : access pthread_key_t;
destructor : destructor_pointer) return int;
pragma Import (C, pthread_key_create, "pthread_key_create");
CPU_SETSIZE : constant := 1_024;
-- Size of the cpu_set_t mask on most linux systems (SUSE 11 uses 4_096).
-- This is kept for backward compatibility (System.Task_Info uses it), but
-- the run-time library does no longer rely on static masks, using
-- dynamically allocated masks instead.
type bit_field is array (1 .. CPU_SETSIZE) of Boolean;
for bit_field'Size use CPU_SETSIZE;
pragma Pack (bit_field);
pragma Convention (C, bit_field);
type cpu_set_t is record
bits : bit_field;
end record;
pragma Convention (C, cpu_set_t);
type cpu_set_t_ptr is access all cpu_set_t;
-- In the run-time library we use this pointer because the size of type
-- cpu_set_t varies depending on the glibc version. Hence, objects of type
-- cpu_set_t are allocated dynamically using the number of processors
-- available in the target machine (value obtained at execution time).
function CPU_ALLOC (count : size_t) return cpu_set_t_ptr;
pragma Import (C, CPU_ALLOC, "__gnat_cpu_alloc");
-- Wrapper around the CPU_ALLOC C macro
function CPU_ALLOC_SIZE (count : size_t) return size_t;
pragma Import (C, CPU_ALLOC_SIZE, "__gnat_cpu_alloc_size");
-- Wrapper around the CPU_ALLOC_SIZE C macro
procedure CPU_FREE (cpuset : cpu_set_t_ptr);
pragma Import (C, CPU_FREE, "__gnat_cpu_free");
-- Wrapper around the CPU_FREE C macro
procedure CPU_ZERO (count : size_t; cpuset : cpu_set_t_ptr);
pragma Import (C, CPU_ZERO, "__gnat_cpu_zero");
-- Wrapper around the CPU_ZERO_S C macro
procedure CPU_SET (cpu : int; count : size_t; cpuset : cpu_set_t_ptr);
pragma Import (C, CPU_SET, "__gnat_cpu_set");
-- Wrapper around the CPU_SET_S C macro
private
type sigset_t is new Interfaces.C.unsigned_long;
pragma Convention (C, sigset_t);
for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment;
type pid_t is new int;
type time_t is new long;
type timespec is record
tv_sec : time_t;
tv_nsec : long;
end record;
pragma Convention (C, timespec);
type unsigned_long_long_t is mod 2 ** 64;
-- Local type only used to get the alignment of this type below
subtype char_array is Interfaces.C.char_array;
type pthread_attr_t is record
Data : char_array (1 .. OS_Constants.PTHREAD_ATTR_SIZE);
end record;
pragma Convention (C, pthread_attr_t);
for pthread_attr_t'Alignment use Interfaces.C.unsigned_long'Alignment;
type pthread_condattr_t is record
Data : char_array (1 .. OS_Constants.PTHREAD_CONDATTR_SIZE);
end record;
pragma Convention (C, pthread_condattr_t);
for pthread_condattr_t'Alignment use Interfaces.C.int'Alignment;
type pthread_mutexattr_t is record
Data : char_array (1 .. OS_Constants.PTHREAD_MUTEXATTR_SIZE);
end record;
pragma Convention (C, pthread_mutexattr_t);
for pthread_mutexattr_t'Alignment use Interfaces.C.int'Alignment;
type pthread_mutex_t is record
Data : char_array (1 .. OS_Constants.PTHREAD_MUTEX_SIZE);
end record;
pragma Convention (C, pthread_mutex_t);
for pthread_mutex_t'Alignment use Interfaces.C.unsigned_long'Alignment;
type pthread_cond_t is record
Data : char_array (1 .. OS_Constants.PTHREAD_COND_SIZE);
end record;
pragma Convention (C, pthread_cond_t);
for pthread_cond_t'Alignment use unsigned_long_long_t'Alignment;
type pthread_key_t is new unsigned;
end System.OS_Interface;

122
gcc/ada/libgnarl/s-qnx.ads Normal file
View File

@ -0,0 +1,122 @@
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . Q N X --
-- --
-- S p e c --
-- --
-- Copyright (C) 2017, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- --
------------------------------------------------------------------------------
-- This is the default version of this package
-- This package encapsulates cpu specific differences between implementations
-- of QNX, in order to share s-osinte-linux.ads.
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package
with Interfaces.C;
package System.QNX is
pragma Preelaborate;
----------
-- Time --
----------
subtype long is Interfaces.C.long;
subtype suseconds_t is Interfaces.C.long;
subtype time_t is Interfaces.C.long;
subtype clockid_t is Interfaces.C.int;
type timespec is record
tv_sec : time_t;
tv_nsec : long;
end record;
pragma Convention (C, timespec);
type timeval is record
tv_sec : time_t;
tv_usec : suseconds_t;
end record;
pragma Convention (C, timeval);
-----------
-- Errno --
-----------
EAGAIN : constant := 11;
EINTR : constant := 4;
EINVAL : constant := 22;
ENOMEM : constant := 12;
EPERM : constant := 1;
ETIMEDOUT : constant := 110;
-------------
-- Signals --
-------------
SIGHUP : constant := 1; -- hangup
SIGINT : constant := 2; -- interrupt (rubout)
SIGQUIT : constant := 3; -- quit (ASCD FS)
SIGILL : constant := 4; -- illegal instruction (not reset)
SIGTRAP : constant := 5; -- trace trap (not reset)
SIGIOT : constant := 6; -- IOT instruction
SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
SIGEMT : constant := 7; -- EMT instruction
SIGDEADLK : constant := 7; -- Mutex deadlock
SIGFPE : constant := 8; -- floating point exception
SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
SIGSEGV : constant := 11; -- segmentation violation
SIGPIPE : constant := 13; -- write on a pipe with no one to read it
SIGALRM : constant := 14; -- alarm clock
SIGTERM : constant := 15; -- software termination signal from kill
SIGUSR1 : constant := 16; -- user defined signal 1
SIGUSR2 : constant := 17; -- user defined signal 2
SIGCHLD : constant := 18; -- child status change
SIGCLD : constant := 18; -- alias for SIGCHLD
SIGPWR : constant := 19; -- power-fail restart
SIGWINCH : constant := 20; -- window size change
SIGURG : constant := 21; -- urgent condition on IO channel
SIGPOLL : constant := 22; -- pollable event occurred
SIGIO : constant := 22; -- I/O now possible (4.2 BSD)
SIGSTOP : constant := 23; -- stop (cannot be caught or ignored)
SIGTSTP : constant := 24; -- user stop requested from tty
SIGCONT : constant := 25; -- stopped process has been continued
SIGTTIN : constant := 26; -- background tty read attempted
SIGTTOU : constant := 27; -- background tty write attempted
SIGVTALRM : constant := 28; -- virtual timer expired
SIGPROF : constant := 29; -- profiling timer expired
SIGXCPU : constant := 30; -- CPU time limit exceeded
SIGXFSZ : constant := 31; -- filesize limit exceeded
-- struct_sigaction offsets
sa_handler_pos : constant := 0;
sa_mask_pos : constant := Standard'Address_Size / 8;
sa_flags_pos : constant := 128 + sa_mask_pos;
SA_SIGINFO : constant := 16#04#;
SA_ONSTACK : constant := 16#08000000#;
end System.QNX;

1546
gcc/ada/libgnarl/s-taprop__qnx.adb Normal file
View File

File diff suppressed because it is too large Load Diff

157
gcc/ada/libgnat/system-qnx-aarch64.ads Normal file
View File

@ -0,0 +1,157 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (QNX/Aarch64 Version) --
-- --
-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package System is
pragma Pure;
-- Note that we take advantage of the implementation permission to make
-- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
-- 2005, this is Pure in any case (AI-362).
pragma No_Elaboration_Code_All;
-- Allow the use of that restriction in units that WITH this unit
type Name is (SYSTEM_NAME_GNAT);
System_Name : constant Name := SYSTEM_NAME_GNAT;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Long_Integer'First;
Max_Int : constant := Long_Long_Integer'Last;
Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.000_001;
-- Storage-related Declarations
type Address is private;
pragma Preelaborable_Initialization (Address);
Null_Address : constant Address;
Storage_Unit : constant := 8;
Word_Size : constant := Standard'Word_Size;
Memory_Size : constant := 2 ** Long_Integer'Size;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
Default_Bit_Order : constant Bit_Order :=
Bit_Order'Val (Standard'Default_Bit_Order);
pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-- Priority-related Declarations (RM D.1)
-- 0 .. 98 corresponds to the system priority range 1 .. 99.
--
-- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use
-- of the entire range provided by the system.
--
-- If the scheduling policy is SCHED_OTHER the only valid system priority
-- is 1 and other values are simply ignored.
Max_Priority : constant Positive := 97;
Max_Interrupt_Priority : constant Positive := 98;
subtype Any_Priority is Integer range 0 .. 98;
subtype Priority is Any_Priority range 0 .. 97;
subtype Interrupt_Priority is Any_Priority range 98 .. 98;
Default_Priority : constant Priority := 48;
private
type Address is mod Memory_Size;
Null_Address : constant Address := 0;
--------------------------------------
-- System Implementation Parameters --
--------------------------------------
-- These parameters provide information about the target that is used
-- by the compiler. They are in the private part of System, where they
-- can be accessed using the special circuitry in the Targparm unit
-- whose source should be consulted for more detailed descriptions
-- of the individual switch values.
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := True;
Command_Line_Args : constant Boolean := True;
Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
Support_Atomic_Primitives : constant Boolean := True;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
Always_Compatible_Rep : constant Boolean := False;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
Frontend_Exceptions : constant Boolean := False;
ZCX_By_Default : constant Boolean := True;
end System;

9
gcc/ada/s-oscons-tmplt.c
View File

@ -157,7 +157,8 @@ pragma Style_Checks ("M32766");
# include <_types.h>
#endif
#if defined (__linux__) || defined (__ANDROID__) || defined (__rtems__)
#if defined (__linux__) || defined (__ANDROID__) || defined (__QNX__) \
|| defined (__rtems__)
# include <pthread.h>
# include <signal.h>
#endif
@ -1191,7 +1192,7 @@ CND(MSG_WAITALL, "Wait for full reception")
#endif
CND(MSG_NOSIGNAL, "No SIGPIPE on send")
#if defined (__linux__) || defined (__ANDROID__)
#if defined (__linux__) || defined (__ANDROID__) || defined (__QNX__)
# define MSG_Forced_Flags "MSG_NOSIGNAL"
#else
# define MSG_Forced_Flags "0"
@ -1361,7 +1362,7 @@ CND(SIZEOF_struct_hostent, "struct hostent")
#define SIZEOF_struct_servent (sizeof (struct servent))
CND(SIZEOF_struct_servent, "struct servent")
#if defined (__linux__) || defined (__ANDROID__)
#if defined (__linux__) || defined (__ANDROID__) || defined (__QNX__)
#define SIZEOF_sigset (sizeof (sigset_t))
CND(SIZEOF_sigset, "sigset")
#endif
@ -1464,7 +1465,7 @@ CNS(CLOCK_RT_Ada, "")
#endif
#if defined (__APPLE__) || defined (__linux__) || defined (__ANDROID__) \
|| defined (__rtems__) || defined (DUMMY)
|| defined (__QNX__) || defined (__rtems__) || defined (DUMMY)
/*
-- Sizes of pthread data types

342
gcc/ada/sem_aggr.adb
View File

@ -418,6 +418,13 @@ package body Sem_Aggr is
-- array of characters is expected. This procedure simply rewrites the
-- string as an aggregate, prior to resolution.
---------------------------------
-- Delta aggregate processing --
---------------------------------
procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id);
------------------------
-- Array_Aggr_Subtype --
------------------------
@ -2759,9 +2766,230 @@ package body Sem_Aggr is
procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is
Base : constant Node_Id := Expression (N);
begin
if not Is_Composite_Type (Typ) then
Error_Msg_N ("not a composite type", N);
end if;
Analyze_And_Resolve (Base, Typ);
if Is_Array_Type (Typ) then
Resolve_Delta_Array_Aggregate (N, Typ);
else
Resolve_Delta_Record_Aggregate (N, Typ);
end if;
Set_Etype (N, Typ);
end Resolve_Delta_Aggregate;
-----------------------------------
-- Resolve_Delta_Array_Aggregate --
-----------------------------------
procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id) is
Deltas : constant List_Id := Component_Associations (N);
Assoc : Node_Id;
Choice : Node_Id;
Index_Type : Entity_Id;
begin
Index_Type := Etype (First_Index (Typ));
Assoc := First (Deltas);
while Present (Assoc) loop
if Nkind (Assoc) = N_Iterated_Component_Association then
Choice := First (Choice_List (Assoc));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Error_Msg_N
("others not allowed in delta aggregate", Choice);
else
Analyze_And_Resolve (Choice, Index_Type);
end if;
Next (Choice);
end loop;
declare
Id : constant Entity_Id := Defining_Identifier (Assoc);
Ent : constant Entity_Id :=
New_Internal_Entity
(E_Loop, Current_Scope, Sloc (Assoc), 'L');
begin
Set_Etype (Ent, Standard_Void_Type);
Set_Parent (Ent, Assoc);
if No (Scope (Id)) then
Enter_Name (Id);
Set_Etype (Id, Index_Type);
Set_Ekind (Id, E_Variable);
Set_Scope (Id, Ent);
end if;
Push_Scope (Ent);
Analyze_And_Resolve
(New_Copy_Tree (Expression (Assoc)), Component_Type (Typ));
End_Scope;
end;
else
Choice := First (Choice_List (Assoc));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Error_Msg_N
("others not allowed in delta aggregate", Choice);
else
Analyze (Choice);
if Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))
then
-- Choice covers a range of values.
if Base_Type (Entity (Choice)) /=
Base_Type (Index_Type)
then
Error_Msg_NE
("choice does mat match index type of",
Choice, Typ);
end if;
else
Resolve (Choice, Index_Type);
end if;
end if;
Next (Choice);
end loop;
Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ));
end if;
Next (Assoc);
end loop;
end Resolve_Delta_Array_Aggregate;
------------------------------------
-- Resolve_Delta_Record_Aggregate --
------------------------------------
procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
Deltas : constant List_Id := Component_Associations (N);
Assoc : Node_Id;
Choice : Node_Id;
Comp_Type : Entity_Id;
-- Variables used to verify that discriminant-dependent components
-- appear in the same variant.
Variant : Node_Id;
Comp_Ref : Entity_Id;
procedure Check_Variant (Id : Entity_Id);
-- If a given component of the delta aggregate appears in a variant
-- part, verify that it is within the same variant as that of previous
-- specified variant components of the delta.
function Nested_In (V1, V2 : Node_Id) return Boolean;
-- Determine whether variant V1 is within variant V2.
function Get_Component_Type (Nam : Node_Id) return Entity_Id;
-- Locate component with a given name and return its type. If none
-- found report error.
function Variant_Depth (N : Node_Id) return Integer;
-- Determine the distance of a variant to the enclosing type
-- declaration.
--------------------
-- Check_Variant --
--------------------
procedure Check_Variant (Id : Entity_Id) is
Comp : Entity_Id;
Comp_Variant : Node_Id;
begin
if not Has_Discriminants (Typ) then
return;
end if;
Comp := First_Entity (Typ);
while Present (Comp) loop
exit when Chars (Comp) = Chars (Id);
Next_Component (Comp);
end loop;
-- Find the variant, if any, whose component list includes the
-- component declaration.
Comp_Variant := Parent (Parent (List_Containing (Parent (Comp))));
if Nkind (Comp_Variant) = N_Variant then
if No (Variant) then
Variant := Comp_Variant;
Comp_Ref := Comp;
elsif Variant /= Comp_Variant then
declare
D1 : constant Integer := Variant_Depth (Variant);
D2 : constant Integer := Variant_Depth (Comp_Variant);
begin
if D1 = D2
or else
(D1 > D2 and then not Nested_In (Variant, Comp_Variant))
or else
(D2 > D1 and then not Nested_In (Comp_Variant, Variant))
then
Error_Msg_Node_2 := Comp_Ref;
Error_Msg_NE
("& and & appear in different variants", Id, Comp);
-- Otherwise retain the deeper variant for subsequent tests
elsif D2 > D1 then
Variant := Comp_Variant;
end if;
end;
end if;
end if;
end Check_Variant;
---------------
-- Nested_In --
---------------
function Nested_In (V1, V2 : Node_Id) return Boolean is
Par : Node_Id;
begin
Par := Parent (V1);
while Nkind (Par) /= N_Full_Type_Declaration loop
if Par = V2 then
return True;
end if;
Par := Parent (Par);
end loop;
return False;
end Nested_In;
-------------------
-- Variant_Depth --
-------------------
function Variant_Depth (N : Node_Id) return Integer is
Depth : Integer;
Par : Node_Id;
begin
Depth := 0;
Par := Parent (N);
while Nkind (Par) /= N_Full_Type_Declaration loop
Depth := Depth + 1;
Par := Parent (Par);
end loop;
return Depth;
end Variant_Depth;
------------------------
-- Get_Component_Type --
@ -2789,113 +3017,27 @@ package body Sem_Aggr is
return Any_Type;
end Get_Component_Type;
-- Local variables
Assoc : Node_Id;
Choice : Node_Id;
Comp_Type : Entity_Id;
Index_Type : Entity_Id;
-- Start of processing for Resolve_Delta_Aggregate
-- Start of processing for Resolve_Delta_Record_Aggregate
begin
if not Is_Composite_Type (Typ) then
Error_Msg_N ("not a composite type", N);
end if;
Variant := Empty;
Assoc := First (Deltas);
Analyze_And_Resolve (Base, Typ);
if Is_Array_Type (Typ) then
Index_Type := Etype (First_Index (Typ));
Assoc := First (Deltas);
while Present (Assoc) loop
if Nkind (Assoc) = N_Iterated_Component_Association then
Choice := First (Choice_List (Assoc));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Error_Msg_N
("others not allowed in delta aggregate", Choice);
else
Analyze_And_Resolve (Choice, Index_Type);
end if;
Next (Choice);
end loop;
declare
Id : constant Entity_Id := Defining_Identifier (Assoc);
Ent : constant Entity_Id :=
New_Internal_Entity
(E_Loop, Current_Scope, Sloc (Assoc), 'L');
begin
Set_Etype (Ent, Standard_Void_Type);
Set_Parent (Ent, Assoc);
if No (Scope (Id)) then
Enter_Name (Id);
Set_Etype (Id, Index_Type);
Set_Ekind (Id, E_Variable);
Set_Scope (Id, Ent);
end if;
Push_Scope (Ent);
Analyze_And_Resolve
(New_Copy_Tree (Expression (Assoc)), Component_Type (Typ));
End_Scope;
end;
else
Choice := First (Choice_List (Assoc));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Error_Msg_N
("others not allowed in delta aggregate", Choice);
else
Analyze (Choice);
if Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))
then
-- Choice covers a range of values.
if Base_Type (Entity (Choice)) /=
Base_Type (Index_Type)
then
Error_Msg_NE
("choice does mat match index type of",
Choice, Typ);
end if;
else
Resolve (Choice, Index_Type);
end if;
end if;
Next (Choice);
end loop;
Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ));
while Present (Assoc) loop
Choice := First (Choice_List (Assoc));
while Present (Choice) loop
Comp_Type := Get_Component_Type (Choice);
if Comp_Type /= Any_Type then
Check_Variant (Choice);
end if;
Next (Assoc);
Next (Choice);
end loop;
else
Assoc := First (Deltas);
while Present (Assoc) loop
Choice := First (Choice_List (Assoc));
while Present (Choice) loop
Comp_Type := Get_Component_Type (Choice);
Next (Choice);
end loop;
Analyze_And_Resolve (Expression (Assoc), Comp_Type);
Next (Assoc);
end loop;
end if;
Set_Etype (N, Typ);
end Resolve_Delta_Aggregate;
Analyze_And_Resolve (Expression (Assoc), Comp_Type);
Next (Assoc);
end loop;
end Resolve_Delta_Record_Aggregate;
---------------------------------
-- Resolve_Extension_Aggregate --

32
gcc/ada/sem_res.adb
View File

@ -5143,6 +5143,38 @@ package body Sem_Res is
if not Is_Static_Coextension (N) then
Set_Is_Dynamic_Coextension (N);
-- ??? We currently do not handle finalization and deallocation
-- of coextensions properly so let's at least warn the user
-- about it.
if Is_Controlled_Active (Desig_T) then
if Is_Controlled_Active
(Defining_Identifier
(Parent (Associated_Node_For_Itype (Typ))))
then
Error_Msg_N
("info: coextension will not be finalized when its "
& "associated owner is finalized", N);
else
Error_Msg_N
("info: coextension will not be finalized when its "
& "associated owner is deallocated", N);
end if;
else
if Is_Controlled_Active
(Defining_Identifier
(Parent (Associated_Node_For_Itype (Typ))))
then
Error_Msg_N
("info: coextension will not be deallocated when its "
& "associated owner is finalized", N);
else
Error_Msg_N
("info: coextension will not be deallocated when its "
& "associated owner is deallocated", N);
end if;
end if;
end if;
-- Cleanup for potential static coextensions

60
gcc/ada/sem_util.adb
View File

@ -7841,6 +7841,66 @@ package body Sem_Util is
raise Program_Error;
end Find_Corresponding_Discriminant;
-------------------
-- Find_DIC_Type --
-------------------
function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is
Curr_Typ : Entity_Id;
-- The current type being examined in the parent hierarchy traversal
DIC_Typ : Entity_Id;
-- The type which carries the DIC pragma. This variable denotes the
-- partial view when private types are involved.
Par_Typ : Entity_Id;
-- The parent type of the current type. This variable denotes the full
-- view when private types are involved.
begin
-- The input type defines its own DIC pragma, therefore it is the owner
if Has_Own_DIC (Typ) then
DIC_Typ := Typ;
-- Otherwise the DIC pragma is inherited from a parent type
else
pragma Assert (Has_Inherited_DIC (Typ));
-- Climb the parent chain
Curr_Typ := Typ;
loop
-- Inspect the parent type. Do not consider subtypes as they
-- inherit the DIC attributes from their base types.
DIC_Typ := Base_Type (Etype (Curr_Typ));
-- Look at the full view of a private type because the type may
-- have a hidden parent introduced in the full view.
Par_Typ := DIC_Typ;
if Is_Private_Type (Par_Typ)
and then Present (Full_View (Par_Typ))
then
Par_Typ := Full_View (Par_Typ);
end if;
-- Stop the climb once the nearest parent type which defines a DIC
-- pragma of its own is encountered or when the root of the parent
-- chain is reached.
exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ;
Curr_Typ := Par_Typ;
end loop;
end if;
return DIC_Typ;
end Find_DIC_Type;
----------------------------------
-- Find_Enclosing_Iterator_Loop --
----------------------------------

5
gcc/ada/sem_util.ads
View File

@ -769,6 +769,11 @@ package Sem_Util is
-- analyzed. Subsequent uses of this id on a different type denotes the
-- discriminant at the same position in this new type.
function Find_DIC_Type (Typ : Entity_Id) return Entity_Id;
-- Subsidiary to all Build_DIC_Procedure_xxx routines. Find the type which
-- defines the Default_Initial_Condition pragma of type Typ. This is either
-- Typ itself or a parent type when the pragma is inherited.
function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id;
-- Find the nearest iterator loop which encloses arbitrary entity Id. If
-- such a loop exists, return the entity of its identifier (E_Loop scope),

301
gcc/ada/sigtramp-qnx.c Normal file
View File

@ -0,0 +1,301 @@
/****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* S I G T R A M P *
* *
* Asm Implementation File *
* *
* Copyright (C) 2017, 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- *
* ware Foundation; either version 3, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. *
* *
* As a special exception under Section 7 of GPL version 3, you are granted *
* additional permissions described in the GCC Runtime Library Exception, *
* version 3.1, as published by the Free Software Foundation. *
* *
* In particular, you can freely distribute your programs built with the *
* GNAT Pro compiler, including any required library run-time units, using *
* any licensing terms of your choosing. See the AdaCore Software License *
* for full details. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* Extensive contributions were provided by Ada Core Technologies Inc. *
* *
****************************************************************************/
/**********************************************
* QNX version of the __gnat_sigtramp service *
**********************************************/
#include <ucontext.h>
#include "sigtramp.h"
/* See sigtramp.h for a general explanation of functionality. */
extern void __gnat_sigtramp_common
(int signo, void *siginfo, void *sigcontext,
__sigtramphandler_t * handler);
void __gnat_sigtramp (int signo, void *si, void *sc,
__sigtramphandler_t * handler)
__attribute__((optimize(2)));
void __gnat_sigtramp (int signo, void *si, void *ucontext,
__sigtramphandler_t * handler)
{
struct sigcontext *mcontext = &((ucontext_t *) ucontext)->uc_mcontext;
__gnat_sigtramp_common (signo, si, mcontext, handler);
}
/* asm string construction helpers. */
#define STR(TEXT) #TEXT
/* stringify expanded TEXT, surrounding it with double quotes. */
#define S(E) STR(E)
/* stringify E, which will resolve as text but may contain macros
still to be expanded. */
/* asm (TEXT) outputs <tab>TEXT. These facilitate the output of
multiline contents: */
#define TAB(S) "\t" S
#define CR(S) S "\n"
#undef TCR
#define TCR(S) TAB(CR(S))
/* Trampoline body block
--------------------- */
#ifdef __x86_64__
/*****************************************
* x86-64 *
*****************************************/
#define COMMON_CFI(REG) \
".cfi_offset " S(REGNO_##REG) "," S(REG_##REG)
// CFI register numbers
#define REGNO_RAX 0
#define REGNO_RDX 1
#define REGNO_RCX 2
#define REGNO_RBX 3
#define REGNO_RSI 4
#define REGNO_RDI 5
#define REGNO_RBP 6
#define REGNO_RSP 7
#define REGNO_R8 8
#define REGNO_R9 9
#define REGNO_R10 10
#define REGNO_R11 11
#define REGNO_R12 12
#define REGNO_R13 13
#define REGNO_R14 14
#define REGNO_R15 15
#define REGNO_RPC 16 /* aka %rip */
// Registers offset from the regset structure
#define REG_RDI 0x00
#define REG_RSI 0x08
#define REG_RDX 0x10
#define REG_R10 0x18
#define REG_R8 0x20
#define REG_R9 0x28
#define REG_RAX 0x30
#define REG_RBX 0x38
#define REG_RBP 0x40
#define REG_RCX 0x48
#define REG_R11 0x50
#define REG_R12 0x58
#define REG_R13 0x60
#define REG_R14 0x68
#define REG_R15 0x70
#define REG_RPC 0x78 /* RIP */
#define REG_RSP 0x90
#define CFI_COMMON_REGS \
CR("# CFI for common registers\n") \
TCR(COMMON_CFI(RSP)) \
TCR(COMMON_CFI(R15)) \
TCR(COMMON_CFI(R14)) \
TCR(COMMON_CFI(R13)) \
TCR(COMMON_CFI(R12)) \
TCR(COMMON_CFI(R11)) \
TCR(COMMON_CFI(RCX)) \
TCR(COMMON_CFI(RBP)) \
TCR(COMMON_CFI(RBX)) \
TCR(COMMON_CFI(RAX)) \
TCR(COMMON_CFI(R9)) \
TCR(COMMON_CFI(R8)) \
TCR(COMMON_CFI(R10)) \
TCR(COMMON_CFI(RSI)) \
TCR(COMMON_CFI(RDI)) \
TCR(COMMON_CFI(RDX)) \
TCR(COMMON_CFI(RPC)) \
TCR(".cfi_return_column " S(REGNO_RPC))
#define SIGTRAMP_BODY \
TCR(".cfi_def_cfa 15, 0") \
CFI_COMMON_REGS \
CR("") \
TCR("# Allocate frame and save the non-volatile") \
TCR("# registers we're going to modify") \
TCR("subq $8, %rsp") \
TCR("# Setup CFA_REG = context, which we'll retrieve as our CFA value") \
TCR("movq %rdx, %r15") \
TCR("# Call the real handler. The signo, siginfo and sigcontext") \
TCR("# arguments are the same as those we received") \
TCR("call *%rcx") \
TCR("# This part should never be executed") \
TCR("addq $8, %rsp") \
TCR("ret")
#endif
#ifdef __aarch64__
/*****************************************
* Aarch64 *
*****************************************/
#define UC_MCONTEXT_SS 16
#define CFA_REG 19
#define BASE_REG 20
#define DW_CFA_def_cfa 0x0c
#define DW_CFA_expression 0x10
#define DW_OP_breg(n) 0x70+(n)
#define REG_REGNO_GR(n) n
#define REG_REGNO_PC 30
/* The first byte of the SLEB128 value of the offset. */
#define REG_OFFSET_GR(n) (UC_MCONTEXT_SS + n * 8)
#define REG_OFFSET_LONG_GR(n) (UC_MCONTEXT_SS + n * 8 + 128)
#define REG_OFFSET_LONG128_GR(n) (UC_MCONTEXT_SS + (n - 16) * 8 + 128)
#define REG_OFFSET_LONG256_GR(n) (UC_MCONTEXT_SS + (n - 32) * 8 + 128)
#define REG_OFFSET_LONG256_PC REG_OFFSET_LONG256_GR(32)
#define CFI_DEF_CFA \
TCR(".cfi_def_cfa " S(CFA_REG) ", 0")
/* We need 4 variants depending on the offset: 0+, 64+, 128+, 256+. */
#define COMMON_CFI(REG) \
".cfi_escape " S(DW_CFA_expression) "," S(REG_REGNO_##REG) ",2," \
S(DW_OP_breg(BASE_REG)) "," S(REG_OFFSET_##REG)
#define COMMON_LONG_CFI(REG) \
".cfi_escape " S(DW_CFA_expression) "," S(REG_REGNO_##REG) ",3," \
S(DW_OP_breg(BASE_REG)) "," S(REG_OFFSET_LONG_##REG) ",0"
#define COMMON_LONG128_CFI(REG) \
".cfi_escape " S(DW_CFA_expression) "," S(REG_REGNO_##REG) ",3," \
S(DW_OP_breg(BASE_REG)) "," S(REG_OFFSET_LONG128_##REG) ",1"
#define COMMON_LONG256_CFI(REG) \
".cfi_escape " S(DW_CFA_expression) "," S(REG_REGNO_##REG) ",3," \
S(DW_OP_breg(BASE_REG)) "," S(REG_OFFSET_LONG256_##REG) ",2"
#define CFI_COMMON_REGS \
CR("# CFI for common registers\n") \
TCR(COMMON_CFI(GR(0))) \
TCR(COMMON_CFI(GR(1))) \
TCR(COMMON_CFI(GR(2))) \
TCR(COMMON_CFI(GR(3))) \
TCR(COMMON_CFI(GR(4))) \
TCR(COMMON_CFI(GR(5))) \
TCR(COMMON_LONG_CFI(GR(6))) \
TCR(COMMON_LONG_CFI(GR(7))) \
TCR(COMMON_LONG_CFI(GR(8))) \
TCR(COMMON_LONG_CFI(GR(9))) \
TCR(COMMON_LONG_CFI(GR(10))) \
TCR(COMMON_LONG_CFI(GR(11))) \
TCR(COMMON_LONG_CFI(GR(12))) \
TCR(COMMON_LONG_CFI(GR(13))) \
TCR(COMMON_LONG128_CFI(GR(14))) \
TCR(COMMON_LONG128_CFI(GR(15))) \
TCR(COMMON_LONG128_CFI(GR(16))) \
TCR(COMMON_LONG128_CFI(GR(17))) \
TCR(COMMON_LONG128_CFI(GR(18))) \
TCR(COMMON_LONG128_CFI(GR(19))) \
TCR(COMMON_LONG128_CFI(GR(20))) \
TCR(COMMON_LONG128_CFI(GR(21))) \
TCR(COMMON_LONG128_CFI(GR(22))) \
TCR(COMMON_LONG128_CFI(GR(23))) \
TCR(COMMON_LONG128_CFI(GR(24))) \
TCR(COMMON_LONG128_CFI(GR(25))) \
TCR(COMMON_LONG128_CFI(GR(26))) \
TCR(COMMON_LONG128_CFI(GR(27))) \
TCR(COMMON_LONG128_CFI(GR(28))) \
TCR(COMMON_LONG128_CFI(GR(29))) \
TCR(COMMON_LONG256_CFI(PC))
#define SIGTRAMP_BODY \
CFI_DEF_CFA \
CFI_COMMON_REGS \
TCR("# Push FP and LR on stack") \
TCR("stp x29, x30, [sp, #-32]!") \
TCR("stp x" S(CFA_REG) ", x" S(BASE_REG) ", [sp, #16]") \
TCR("mov x29, sp") \
TCR("# Load the saved value of the stack pointer as CFA") \
TCR("ldr x" S(CFA_REG) ", [x2, #" S(REG_OFFSET_GR(31)) "]") \
TCR("# Use x" S(BASE_REG) " as base register for the CFI") \
TCR("mov x" S(BASE_REG) ", x2") \
TCR("# Call the handler") \
TCR("blr x3") \
TCR("# Release our frame and return (should never get here!).") \
TCR("ldp x" S(CFA_REG) ", x" S(BASE_REG)" , [sp, #16]") \
TCR("ldp x29, x30, [sp], 32") \
TCR("ret")
#endif /* AARCH64 */
/* Symbol definition block
----------------------- */
#if defined (__x86_64__) || defined (__aarch64__)
#define FUNC_ALIGN TCR(".p2align 4,,15")
#else
#define FUNC_ALIGN
#endif
#define SIGTRAMP_START(SYM) \
CR("# " S(SYM) " cfi trampoline") \
TCR(".type " S(SYM) ", @function") \
CR("") \
FUNC_ALIGN \
CR(S(SYM) ":") \
TCR(".cfi_startproc") \
TCR(".cfi_signal_frame")
/* Symbol termination block
------------------------ */
#define SIGTRAMP_END(SYM) \
CR(".cfi_endproc") \
TCR(".size " S(SYM) ", .-" S(SYM))
/*----------------------------
-- And now, the real code --
---------------------------- */
/* Text section start. The compiler isn't aware of that switch. */
asm (".text\n"
TCR(".align 2"));
/* sigtramp stub for common registers. */
#define TRAMP_COMMON __gnat_sigtramp_common
asm (SIGTRAMP_START(TRAMP_COMMON));
asm (SIGTRAMP_BODY);
asm (SIGTRAMP_END(TRAMP_COMMON));

4
gcc/ada/terminals.c
View File

@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
* Copyright (C) 2008-2016, AdaCore *
* Copyright (C) 2008-2017, 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- *
@ -1111,7 +1111,7 @@ __gnat_setup_winsize (void *desc, int rows, int columns)
/* On some system termio is either absent or including it will disable termios
(HP-UX) */
#if !defined (__hpux__) && !defined (BSD) && !defined (__APPLE__) \
&& !defined (__rtems__)
&& !defined (__rtems__) && !defined (__QNXNTO__)
# include <termio.h>
#endif