aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog24
-rw-r--r--gcc/ada/clean.adb1
-rw-r--r--gcc/ada/ctrl_c.c34
-rw-r--r--gcc/ada/init.c97
-rw-r--r--gcc/ada/makeutl.adb67
-rw-r--r--gcc/ada/opt.ads4
-rw-r--r--gcc/ada/prj-nmsc.adb50
7 files changed, 188 insertions, 89 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 6bd9853..c6e9cdd 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -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).
diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb
index 9d9c4d4..aa95c8d 100644
--- a/gcc/ada/clean.adb
+++ b/gcc/ada/clean.adb
@@ -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;
diff --git a/gcc/ada/ctrl_c.c b/gcc/ada/ctrl_c.c
index a860b76..7f8d177 100644
--- a/gcc/ada/ctrl_c.c
+++ b/gcc/ada/ctrl_c.c
@@ -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 */
diff --git a/gcc/ada/init.c b/gcc/ada/init.c
index d5057c8..8408225 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -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. */
diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb
index dc28bfd..d81aa0a 100644
--- a/gcc/ada/makeutl.adb
+++ b/gcc/ada/makeutl.adb
@@ -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.
-
- 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;
+ 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 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
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index 0d39573..bbf6e29 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -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
diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb
index 758cd52..c3b6ed5 100644
--- a/gcc/ada/prj-nmsc.adb
+++ b/gcc/ada/prj-nmsc.adb
@@ -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;
generated by cgit v1.1 at 2024-11-03 10:53:17 +0000