* *
* 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- *
/* 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>
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;
sigaction (SIGINT, &act, &original_act);
}
+#ifdef VMS
+ sigint_intercepted = &dummy_handler;
+ __gnat_ctrl_c_handler = proc;
+#else
sigint_intercepted = proc;
+#endif
}
/* Restore original handler */
sigaction (SIGINT, &original_act, 0);
sigint_intercepted = 0;
}
+#ifdef VMS
+ if (__gnat_ctrl_c_handler)
+ __gnat_ctrl_c_handler = 0;
+#endif
}
/* Windows implementation */
/* 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
/* 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 */
#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;
};
must be declared. */
#define FAC_MASK 0x0fff0000
-#define MSG_MASK 0x0000fff8
#define DECADA_M_FACILITY 0x00310000
#define ADA$_ALREADY_OPEN 0x0031a594
#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},
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},
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,
0
};
-static const int facility_resignal_table [] = {
+static const int facility_resignal_table [] =
+{
0x1380000, /* RDB */
0x2220000, /* SQL */
0
/* 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)
{
/* 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 [])
{
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)
{
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)
/* 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;
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
};
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). */
/* 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;
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;
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}
};
__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. */
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
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
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;
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;
projects / gcc.git / commitdiff