Skip to content

R
riscv-gcc-1
Commit 8d9a1ba7 by Pierre-Marie de Rodat
Options

[multiple changes] 

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
parent 76b37a56
Showing with 979 additions and 81 deletions
gcc/ada/ChangeLog
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.
* lib-xref-spark_specific.adb (Add_SPARK_Scope): Skip initialization of
removed component.
......
gcc/ada/adaint.c
......@@ -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");
......
gcc/ada/exp_spark.adb
......@@ -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
......
gcc/ada/exp_util.adb
......@@ -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 --
------------------------
......
gcc/ada/init.c
......@@ -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
......
gcc/ada/lib-xref-spark_specific.adb
......@@ -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 --
--------------------
......
gcc/ada/lib-xref.ads
......@@ -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;
-----------------
......
gcc/ada/libgnarl/a-intnam__qnx.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/libgnarl/s-qnx.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/libgnat/system-qnx-aarch64.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-oscons-tmplt.c
......@@ -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
......
gcc/ada/sem_res.adb
......@@ -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
......
gcc/ada/sem_util.adb
......@@ -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 --
----------------------------------
......
gcc/ada/sem_util.ads
......@@ -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),
......
gcc/ada/sigtramp-qnx.c 0 → 100644
/****************************************************************************
* *
* 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));
gcc/ada/terminals.c
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment