procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2013-04-12  Doug Rupp  <rupp@adacore.com>

	* init.c (SS$_CONTROLC, SS$_CONTINUE) [VMS]: New macros.
	(__gnat_handle_vms_condition) [VMS]: Dispatch on the Crtl/C user
	handler if installed.
	* ctrl_c.c (__gnat_install_int_handler)
	[VMS]: Install a dummy sigaction handler to trigger the real
	user handler dispatch in init.c/__gnat_handle_vms_condition.
	(__gnat_uninstall_int_handler) [VMS]: Likewise.

2013-04-12  Vincent Celier  <celier@adacore.com>

	* clean.adb (Parse_Cmd_Line): Set Directories_Must_Exist_In_Projects
	to False if switch is specified.
	* makeutl.adb (Initialize_Source_Record): Do not look for the
	object file if there is no object directory.
	* opt.ads (Directories_Must_Exist_In_Projects): New Boolean
	variable, defaulted to True.
	* prj-nmsc.adb (Check_Library_Attributes): Do not fail if library
	directory does not exist when Directories_Must_Exist_In_Projects is
	False.
	(Get_Directories): Do not fail when the object or the exec directory
	do not exist when Directories_Must_Exist_In_Projects is False.

From-SVN: r197918
This commit is contained in:
Arnaud Charlet 2013-04-12 15:42:39 +02:00
parent b69cd36a46
commit 4bc0caddeb
7 changed files with 187 additions and 88 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

24
gcc/ada/ChangeLog
View file

@ -1,3 +1,27 @@
2013-04-12 Doug Rupp <rupp@adacore.com>
* init.c (SS$_CONTROLC, SS$_CONTINUE) [VMS]: New macros.
(__gnat_handle_vms_condition) [VMS]: Dispatch on the Crtl/C user
handler if installed.
* ctrl_c.c (__gnat_install_int_handler)
[VMS]: Install a dummy sigaction handler to trigger the real
user handler dispatch in init.c/__gnat_handle_vms_condition.
(__gnat_uninstall_int_handler) [VMS]: Likewise.
2013-04-12 Vincent Celier <celier@adacore.com>
* clean.adb (Parse_Cmd_Line): Set Directories_Must_Exist_In_Projects
to False if switch is specified.
* makeutl.adb (Initialize_Source_Record): Do not look for the
object file if there is no object directory.
* opt.ads (Directories_Must_Exist_In_Projects): New Boolean
variable, defaulted to True.
* prj-nmsc.adb (Check_Library_Attributes): Do not fail if library
directory does not exist when Directories_Must_Exist_In_Projects is
False.
(Get_Directories): Do not fail when the object or the exec directory
do not exist when Directories_Must_Exist_In_Projects is False.
2013-04-12 Robert Dewar <dewar@adacore.com>
* namet.adb, namet.ads: Minor addition (7 arg version of Nam_In).

1
gcc/ada/clean.adb
View file

@ -1729,6 +1729,7 @@ package body Clean is
when 'f' =>
Force_Deletions := True;
Directories_Must_Exist_In_Projects := False;
when 'F' =>
Full_Path_Name_For_Brief_Errors := True;

34
gcc/ada/ctrl_c.c
View file

@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
* Copyright (C) 2002-2009, Free Software Foundation, Inc. *
* Copyright (C) 2002-2013, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@ -50,7 +50,24 @@ void __gnat_uninstall_int_handler (void);
/* POSIX implementation */
#if (defined (__unix__) || defined (_AIX) || defined (__APPLE__)) \
&& !defined (__vxworks)
|| defined (VMS) && !defined (__vxworks)
#ifdef VMS
/* On VMS _gnat_handle_vms_condition gets control first, and it has to
resignal the Ctrl/C in order for sigaction to gain control and execute
the user handler routine, but in doing so propagates the condition
causing the program to terminate. So instead we install a dummy handler
routine and put the real user handler in a special global variable so
that __gnat_handle_vms_condition can declare an AST to asynchronously
execute the Ctrl/C user handler at some future time and allow
__gnat_handle_vms_condition to return and not be held up waiting for
the potentially unbounded time required to execute the Crtl/C handler. */
void
dummy_handler () {}
/* Lives in init.c. */
extern void (*__gnat_ctrl_c_handler) (void);
#endif
#include <signal.h>
@ -75,8 +92,8 @@ __gnat_install_int_handler (void (*proc) (void))
if (sigint_intercepted == 0)
{
act.sa_handler = __gnat_int_handler;
#if defined (__Lynx__)
/* LynxOS does not support SA_RESTART. */
#if defined (__Lynx__) || defined (VMS)
/* LynxOS and VMS do not support SA_RESTART. */
act.sa_flags = 0;
#else
act.sa_flags = SA_RESTART;
@ -85,7 +102,12 @@ __gnat_install_int_handler (void (*proc) (void))
sigaction (SIGINT, &act, &original_act);
}
#ifdef VMS
sigint_intercepted = &dummy_handler;
__gnat_ctrl_c_handler = proc;
#else
sigint_intercepted = proc;
#endif
}
/* Restore original handler */
@ -98,6 +120,10 @@ __gnat_uninstall_int_handler (void)
sigaction (SIGINT, &original_act, 0);
sigint_intercepted = 0;
}
#ifdef VMS
if (__gnat_ctrl_c_handler)
__gnat_ctrl_c_handler = 0;
#endif
}
/* Windows implementation */

97
gcc/ada/init.c
View file

@ -804,6 +804,7 @@ __gnat_install_handler (void)
/* Routine called from binder to override default feature values. */
void __gnat_set_features (void);
int __gnat_features_set = 0;
void (*__gnat_ctrl_c_handler) (void) = 0;
#ifdef __IA64
#define lib_get_curr_invo_context LIB$I64_GET_CURR_INVO_CONTEXT
@ -818,10 +819,12 @@ int __gnat_features_set = 0;
/* Define macro symbols for the VMS conditions that become Ada exceptions.
It would be better to just include <ssdef.h> */
#define SS$_CONTINUE 1
#define SS$_ACCVIO 12
#define SS$_HPARITH 1284
#define SS$_INTDIV 1156
#define SS$_STKOVF 1364
#define SS$_CONTROLC 1617
#define SS$_RESIGNAL 2328
#define MTH$_FLOOVEMAT 1475268 /* Some ACVC_21 CXA tests */
@ -841,24 +844,28 @@ extern int LIB$_ACTIMAGE;
#define FDL$_UNPRIKW 11829410
#define CMA$_EXIT_THREAD 4227492
struct cond_sigargs {
struct cond_sigargs
{
unsigned int sigarg;
unsigned int sigargval;
};
struct cond_subtests {
struct cond_subtests
{
unsigned int num;
const struct cond_sigargs sigargs[];
};
struct cond_except {
struct cond_except
{
unsigned int cond;
const struct Exception_Data *except;
unsigned int needs_adjust; /* 1 = adjust PC, 0 = no adjust */
const struct cond_subtests *subtests;
};
struct descriptor_s {
struct descriptor_s
{
unsigned short len, mbz;
__char_ptr32 adr;
};
@ -907,7 +914,6 @@ extern Exception_Code Base_Code_In (Exception_Code);
must be declared. */
#define FAC_MASK 0x0fff0000
#define MSG_MASK 0x0000fff8
#define DECADA_M_FACILITY 0x00310000
#define ADA$_ALREADY_OPEN 0x0031a594
@ -938,7 +944,8 @@ extern Exception_Code Base_Code_In (Exception_Code);
#define ADA$_USE_ERROR 0x0031a8a4
/* DEC Ada specific conditions. */
static const struct cond_except dec_ada_cond_except_table [] = {
static const struct cond_except dec_ada_cond_except_table [] =
{
{ADA$_PROGRAM_ERROR, &program_error, 0, 0},
{ADA$_USE_ERROR, &Use_Error, 0, 0},
{ADA$_KEYSIZERR, &program_error, 0, 0},
@ -986,18 +993,19 @@ static const struct cond_except dec_ada_cond_except_table [] = {
in hindsight should have just made ACCVIO == Storage_Error. */
#define ACCVIO_VIRTUAL_ADDR 3
static const struct cond_subtests accvio_c_e =
{1, /* number of subtests below */
{
{ACCVIO_VIRTUAL_ADDR, 0}
}
};
{1, /* number of subtests below */
{
{ ACCVIO_VIRTUAL_ADDR, 0 }
}
};
/* Macro flag to adjust PC which gets off by one for some conditions,
not sure if this is reliably true, PC could be off by more for
HPARITH for example, unless a trapb is inserted. */
#define NEEDS_ADJUST 1
static const struct cond_except system_cond_except_table [] = {
static const struct cond_except system_cond_except_table [] =
{
{MTH$_FLOOVEMAT, &constraint_error, 0, 0},
{SS$_INTDIV, &constraint_error, 0, 0},
{SS$_HPARITH, &constraint_error, NEEDS_ADJUST, 0},
@ -1039,7 +1047,8 @@ static const struct cond_except system_cond_except_table [] = {
typedef int
resignal_predicate (int code);
static const int * const cond_resignal_table [] = {
static const int * const cond_resignal_table [] =
{
&C$_SIGKILL,
(int *)CMA$_EXIT_THREAD,
&SS$_DEBUG,
@ -1050,7 +1059,8 @@ static const int * const cond_resignal_table [] = {
0
};
static const int facility_resignal_table [] = {
static const int facility_resignal_table [] =
{
0x1380000, /* RDB */
0x2220000, /* SQL */
0
@ -1098,7 +1108,6 @@ __gnat_set_resignal_predicate (resignal_predicate *predicate)
/* Action routine for SYS$PUTMSG. There may be multiple
conditions, each with text to be appended to MESSAGE
and separated by line termination. */
static int
copy_msg (struct descriptor_s *msgdesc, char *message)
{
@ -1124,7 +1133,6 @@ copy_msg (struct descriptor_s *msgdesc, char *message)
/* Scan TABLE for a match for the condition contained in SIGARGS,
and return the entry, or the empty entry if no match found. */
static const struct cond_except *
scan_conditions ( int *sigargs, const struct cond_except *table [])
{
@ -1173,6 +1181,8 @@ static const struct cond_except *
return &(*table) [i];
}
/* __gnat_handle_vms_condtition is both a frame based handler
for the runtime, and an exception vector for the compiler. */
long
__gnat_handle_vms_condition (int *sigargs, void *mechargs)
{
@ -1210,6 +1220,19 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs)
const struct cond_except *cond_tables [] = {dec_ada_cond_except_table,
system_cond_except_table,
0};
unsigned int ctrlc = SS$_CONTROLC;
int ctrlc_match = LIB$MATCH_COND (&sigargs [1], &ctrlc);
extern int SYS$DCLAST (void (*astadr)(), unsigned long long astprm,
unsigned int acmode);
/* If SS$_CONTROLC has been imported as an exception, it will take
priority over a a Ctrl/C handler. See above. */
if (ctrlc_match && __gnat_ctrl_c_handler)
{
SYS$DCLAST (__gnat_ctrl_c_handler, 0, 0);
return SS$_CONTINUE;
}
i = 0;
while ((cond_table = cond_tables[i++]) && !exception)
@ -1236,12 +1259,16 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs)
/* Subtract PC & PSL fields as per ABI for SYS$PUTMSG. */
sigargs[0] -= 2;
extern int SYS$PUTMSG (void *, int (*)(), void *, unsigned long long);
/* If it was a DEC Ada specific condtiion, make it GNAT otherwise
keep the old facility. */
if (sigargs [1] & FAC_MASK == DECADA_M_FACILITY)
SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message);
SYS$PUTMSG (sigargs, copy_msg, &gnat_facility,
(unsigned long long ) message);
else
SYS$PUTMSG (sigargs, copy_msg, 0, message);
SYS$PUTMSG (sigargs, copy_msg, 0,
(unsigned long long ) message);
/* Add back PC & PSL fields as per ABI for SYS$PUTMSG. */
sigargs[0] += 2;
@ -1259,6 +1286,8 @@ __gnat_install_handler (void)
long prvhnd ATTRIBUTE_UNUSED;
#if !defined (IN_RTS)
extern int SYS$SETEXV (unsigned int vector, int (*addres)(),
unsigned int accmode, void *(*(prvhnd)));
SYS$SETEXV (1, __gnat_handle_vms_condition, 3, &prvhnd);
#endif
@ -1384,15 +1413,14 @@ struct regsum
};
extern int SYS$GET_REGION_INFO (unsigned int, unsigned long long *,
void *, void *, unsigned int,
void *, unsigned int *);
void *, void *, unsigned int,
void *, unsigned int *);
extern int SYS$EXPREG_64 (unsigned long long *, unsigned long long,
unsigned int, unsigned int, void **,
unsigned long long *);
unsigned int, unsigned int, void **,
unsigned long long *);
extern int SYS$SETPRT_64 (void *, unsigned long long, unsigned int,
unsigned int, void **, unsigned long long *,
unsigned int *);
extern int SYS$PUTMSG (void *, int (*)(), void *, unsigned long long);
unsigned int, void **, unsigned long long *,
unsigned int *);
/* Add a guard page in the memory region containing ADDR at ADDR +/- SIZE.
(The sign depends on the kind of the memory region). */
@ -1418,7 +1446,7 @@ __gnat_set_stack_guard_page (void *addr, unsigned long size)
/* Extend the region. */
status = SYS$EXPREG_64 (&buffer.q_region_id,
size, 0, 0, &start_va, &length);
size, 0, 0, &start_va, &length);
if ((status & 1) != 1)
return -1;
@ -1428,7 +1456,7 @@ __gnat_set_stack_guard_page (void *addr, unsigned long size)
start_va = (void *)((unsigned long long)start_va + length - VMS_PAGESIZE);
status = SYS$SETPRT_64 (start_va, VMS_PAGESIZE, PSL__C_USER, PRT__C_NA,
&ret_va, &ret_len, &ret_prot);
&ret_va, &ret_len, &ret_prot);
if ((status & 1) != 1)
return -1;
@ -1479,7 +1507,8 @@ struct feature {
int __gl_heap_size = 64;
/* Array feature logical names and global variable addresses. */
static const struct feature features[] = {
static const struct feature features[] =
{
{"GNAT$NO_MALLOC_64", &__gl_heap_size},
{0, 0}
};
@ -1496,13 +1525,13 @@ __gnat_set_features (void)
__gnat_vms_get_logical (features[i].name, buff, sizeof (buff));
if (strcmp (buff, "ENABLE") == 0
|| strcmp (buff, "TRUE") == 0
|| strcmp (buff, "1") == 0)
*features[i].gl_addr = 32;
|| strcmp (buff, "TRUE") == 0
|| strcmp (buff, "1") == 0)
*features[i].gl_addr = 32;
else if (strcmp (buff, "DISABLE") == 0
|| strcmp (buff, "FALSE") == 0
|| strcmp (buff, "0") == 0)
*features[i].gl_addr = 64;
|| strcmp (buff, "FALSE") == 0
|| strcmp (buff, "0") == 0)
*features[i].gl_addr = 64;
}
/* Features to artificially limit the stack size. */

65
gcc/ada/makeutl.adb
View file

@ -1256,43 +1256,46 @@ package body Makeutl is
Obj_Proj := Source.Project;
while Obj_Proj /= No_Project loop
declare
Dir : constant String :=
Get_Name_String
(Obj_Proj.Object_Directory.Display_Name);
if Obj_Proj.Object_Directory /= No_Path_Information then
declare
Dir : constant String :=
Get_Name_String
(Obj_Proj.Object_Directory.Display_Name);
Object_Path : constant String :=
Normalize_Pathname
(Name =>
Get_Name_String (Source.Object),
Resolve_Links => Opt.Follow_Links_For_Files,
Directory => Dir);
Object_Path : constant String :=
Normalize_Pathname
(Name =>
Get_Name_String (Source.Object),
Resolve_Links => Opt.Follow_Links_For_Files,
Directory => Dir);
Obj_Path : constant Path_Name_Type := Create_Name (Object_Path);
Stamp : Time_Stamp_Type := Empty_Time_Stamp;
Obj_Path : constant Path_Name_Type :=
Create_Name (Object_Path);
Stamp : Time_Stamp_Type := Empty_Time_Stamp;
begin
-- For specs, we do not check object files if there is a body.
-- This saves a system call. On the other hand, we do need to
-- know the object_path, in case the user has passed the .ads
-- on the command line to compile the spec only.
begin
-- For specs, we do not check object files if there is a
-- body. This saves a system call. On the other hand, we do
-- need to know the object_path, in case the user has passed
-- the .ads on the command line to compile the spec only.
if Source.Kind /= Spec
or else Source.Unit = No_Unit_Index
or else Source.Unit.File_Names (Impl) = No_Source
then
Stamp := File_Stamp (Obj_Path);
end if;
if Source.Kind /= Spec
or else Source.Unit = No_Unit_Index
or else Source.Unit.File_Names (Impl) = No_Source
then
Stamp := File_Stamp (Obj_Path);
end if;
if Stamp /= Empty_Time_Stamp
or else (Obj_Proj.Extended_By = No_Project
and then Source.Object_Project = No_Project)
then
Set_Object_Project (Dir, Obj_Proj, Obj_Path, Stamp);
end if;
if Stamp /= Empty_Time_Stamp
or else (Obj_Proj.Extended_By = No_Project
and then Source.Object_Project = No_Project)
then
Set_Object_Project (Dir, Obj_Proj, Obj_Path, Stamp);
end if;
end;
end if;
Obj_Proj := Obj_Proj.Extended_By;
end;
Obj_Proj := Obj_Proj.Extended_By;
end loop;
elsif Source.Language.Config.Dependency_Kind = Makefile then

4
gcc/ada/opt.ads
View file

@ -436,6 +436,10 @@ package Opt is
-- Set True to force the run time to raise Program_Error if calls to
-- potentially blocking operations are detected from protected actions.
Directories_Must_Exist_In_Projects : Boolean := True;
-- PROJECT MANAGER
-- Set to False with switch -f of gnatclean and gprclean
Display_Compilation_Progress : Boolean := False;
-- GNATMAKE, GPRMAKE, GPRBUILD
-- Set True (-d switch) to display information on progress while compiling

50
gcc/ada/prj-nmsc.adb
View file

@ -3155,16 +3155,19 @@ package body Prj.Nmsc is
end if;
if not Dir_Exists then
if Directories_Must_Exist_In_Projects then
-- Get the absolute name of the library directory that does
-- not exist, to report an error.
-- Get the absolute name of the library directory that
-- does not exist, to report an error.
Err_Vars.Error_Msg_File_1 :=
File_Name_Type (Project.Library_Dir.Display_Name);
Error_Msg
(Data.Flags,
"library directory { does not exist",
Lib_Dir.Location, Project);
end if;
Err_Vars.Error_Msg_File_1 :=
File_Name_Type (Project.Library_Dir.Display_Name);
Error_Msg
(Data.Flags,
"library directory { does not exist",
Lib_Dir.Location, Project);
Project.Library_Dir := No_Path_Information;
-- Checks for object/source directories
@ -5407,15 +5410,20 @@ package body Prj.Nmsc is
Externally_Built => Project.Externally_Built);
if not Dir_Exists and then not Project.Externally_Built then
if Opt.Directories_Must_Exist_In_Projects then
-- The object directory does not exist, report an error if
-- the project is not externally built.
-- The object directory does not exist, report an error if the
-- project is not externally built.
Err_Vars.Error_Msg_File_1 :=
File_Name_Type (Object_Dir.Value);
Error_Or_Warning
(Data.Flags, Data.Flags.Require_Obj_Dirs,
"object directory { not found",
Project.Location, Project);
end if;
Project.Object_Directory := No_Path_Information;
Err_Vars.Error_Msg_File_1 :=
File_Name_Type (Object_Dir.Value);
Error_Or_Warning
(Data.Flags, Data.Flags.Require_Obj_Dirs,
"object directory { not found", Project.Location, Project);
end if;
end if;
@ -5488,10 +5496,14 @@ package body Prj.Nmsc is
Externally_Built => Project.Externally_Built);
if not Dir_Exists then
Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value);
Error_Or_Warning
(Data.Flags, Data.Flags.Missing_Source_Files,
"exec directory { not found", Project.Location, Project);
if Opt.Directories_Must_Exist_In_Projects then
Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value);
Error_Or_Warning
(Data.Flags, Data.Flags.Missing_Source_Files,
"exec directory { not found", Project.Location, Project);
end if;
Project.Exec_Directory := No_Path_Information;
end if;
end if;
end if;