Length : Nat;
-- Maximum total length of lines
- Txt : constant String_Ptr := Errors.Table (E).Text;
- Len : constant Natural := Txt'Length;
- Ptr : Natural;
- Split : Natural;
- Start : Natural;
+ Text : constant String_Ptr := Errors.Table (E).Text;
+ Warn : constant Boolean := Errors.Table (E).Warn;
+ Warn_Chr : constant Character := Errors.Table (E).Warn_Chr;
+ Warn_Tag : String_Ptr;
+ Ptr : Natural;
+ Split : Natural;
+ Start : Natural;
begin
+ -- Add warning doc tag if needed
+
+ if Warn and then Warn_Chr /= ' ' then
+ if Warn_Chr = '?' then
+ Warn_Tag := new String'(" [enabled by default]");
+
+ elsif Warn_Chr in 'a' .. 'z' then
+ Warn_Tag := new String'(" [-gnatw" & Warn_Chr & ']');
+
+ else pragma Assert (Warn_Chr in 'A' .. 'Z');
+ Warn_Tag :=
+ new String'(" [-gnatw."
+ & Character'Val (Character'Pos (Warn_Chr) + 32)
+ & ']');
+ end if;
+
+ else
+ Warn_Tag := new String'("");
+ end if;
+
+ -- Set error message line length
+
if Error_Msg_Line_Length = 0 then
Length := Nat'Last;
else
Max := Integer (Length - Column + 1);
- -- For warning message, add "warning: " unless msg starts with "info: "
+ declare
+ Txt : constant String := Text.all & Warn_Tag.all;
+ Len : constant Natural := Txt'Length;
- if Errors.Table (E).Warn then
- if Len < 6 or else Txt (Txt'First .. Txt'First + 5) /= "info: " then
- Write_Str ("warning: ");
- Max := Max - 9;
- end if;
+ begin
+ -- For warning, add "warning: " unless msg starts with "info: "
- -- No prefix needed for style message, since "(style)" is there already
+ if Errors.Table (E).Warn then
+ if Len < 6
+ or else Txt (Txt'First .. Txt'First + 5) /= "info: "
+ then
+ Write_Str ("warning: ");
+ Max := Max - 9;
+ end if;
- elsif Errors.Table (E).Style then
- null;
+ -- No prefix needed for style message, "(style)" is there already
- -- All other cases, add "error: "
+ elsif Errors.Table (E).Style then
+ null;
- elsif Opt.Unique_Error_Tag then
- Write_Str ("error: ");
- Max := Max - 7;
- end if;
+ -- All other cases, add "error: "
- -- Here we have to split the message up into multiple lines
+ elsif Opt.Unique_Error_Tag then
+ Write_Str ("error: ");
+ Max := Max - 7;
+ end if;
- Ptr := 1;
- loop
- -- Make sure we do not have ludicrously small line
+ -- Here we have to split the message up into multiple lines
- Max := Integer'Max (Max, 20);
+ Ptr := 1;
+ loop
+ -- Make sure we do not have ludicrously small line
- -- If remaining text fits, output it respecting LF and we are done
+ Max := Integer'Max (Max, 20);
- if Len - Ptr < Max then
- for J in Ptr .. Len loop
- if Txt (J) = ASCII.LF then
- Write_Eol;
- Write_Spaces (Offs);
- else
- Write_Char (Txt (J));
- end if;
- end loop;
+ -- If remaining text fits, output it respecting LF and we are done
- return;
+ if Len - Ptr < Max then
+ for J in Ptr .. Len loop
+ if Txt (J) = ASCII.LF then
+ Write_Eol;
+ Write_Spaces (Offs);
+ else
+ Write_Char (Txt (J));
+ end if;
+ end loop;
+
+ return;
-- Line does not fit
- else
- Start := Ptr;
+ else
+ Start := Ptr;
- -- First scan forward looking for a hard end of line
+ -- First scan forward looking for a hard end of line
- for Scan in Ptr .. Ptr + Max - 1 loop
- if Txt (Scan) = ASCII.LF then
- Split := Scan - 1;
- Ptr := Scan + 1;
- goto Continue;
- end if;
- end loop;
+ for Scan in Ptr .. Ptr + Max - 1 loop
+ if Txt (Scan) = ASCII.LF then
+ Split := Scan - 1;
+ Ptr := Scan + 1;
+ goto Continue;
+ end if;
+ end loop;
- -- Otherwise scan backwards looking for a space
+ -- Otherwise scan backwards looking for a space
- for Scan in reverse Ptr .. Ptr + Max - 1 loop
- if Txt (Scan) = ' ' then
- Split := Scan - 1;
- Ptr := Scan + 1;
- goto Continue;
- end if;
- end loop;
+ for Scan in reverse Ptr .. Ptr + Max - 1 loop
+ if Txt (Scan) = ' ' then
+ Split := Scan - 1;
+ Ptr := Scan + 1;
+ goto Continue;
+ end if;
+ end loop;
- -- If we fall through, no space, so split line arbitrarily
+ -- If we fall through, no space, so split line arbitrarily
- Split := Ptr + Max - 1;
- Ptr := Split + 1;
- end if;
+ Split := Ptr + Max - 1;
+ Ptr := Split + 1;
+ end if;
- <<Continue>>
- if Start <= Split then
- Write_Line (Txt (Start .. Split));
- Write_Spaces (Offs);
- end if;
+ <<Continue>>
+ if Start <= Split then
+ Write_Line (Txt (Start .. Split));
+ Write_Spaces (Offs);
+ end if;
- Max := Integer (Length - Column + 1);
- end loop;
+ Max := Integer (Length - Column + 1);
+ end loop;
+ end;
end Output_Msg_Text;
--------------------
-- Remove upper case letter at end, again, we should not be getting
-- such names, and what we hope is that the remainder makes sense.
- if Name_Len > 1
- and then Name_Buffer (Name_Len) in 'A' .. 'Z'
- then
+ if Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' then
Name_Len := Name_Len - 1;
end if;
and then (J = Msg'First or else Msg (J - 1) /= ''')
then
Is_Warning_Msg := True;
+ Warning_Msg_Char := ' ';
elsif Msg (J) = '<'
and then (J = Msg'First or else Msg (J - 1) /= ''')
then
Is_Warning_Msg := Error_Msg_Warn;
+ Warning_Msg_Char := ' ';
elsif Msg (J) = '|'
and then (J = Msg'First or else Msg (J - 1) /= ''')
#endif
/* Define macro symbols for the VMS conditions that become Ada exceptions.
- Most of these are also defined in the header file ssdef.h which has not
- yet been converted to be recognized by GNU C. */
+ It would be better to just include <ssdef.h> */
-/* Defining these as macros, as opposed to external addresses, allows
- them to be used in a case statement below. */
#define SS$_ACCVIO 12
#define SS$_HPARITH 1284
+#define SS$_INTDIV 1156
#define SS$_STKOVF 1364
#define SS$_RESIGNAL 2328
+#define MTH$_FLOOVEMAT 1475268 /* Some ACVC_21 CXA tests */
+
+/* The following codes must be resignalled, and not handled here. */
+
/* These codes are in standard message libraries. */
extern int C$_SIGKILL;
extern int SS$_DEBUG;
extern int LIB$_KEYNOTFOU;
extern int LIB$_ACTIMAGE;
-#define CMA$_EXIT_THREAD 4227492
-#define MTH$_FLOOVEMAT 1475268 /* Some ACVC_21 CXA tests */
-#define SS$_INTDIV 1156
/* These codes are non standard, which is to say the author is
not sure if they are defined in the standard message libraries
so keep them as macros for now. */
#define RDB$_STREAM_EOF 20480426
#define FDL$_UNPRIKW 11829410
+#define CMA$_EXIT_THREAD 4227492
+
+struct cond_sigargs {
+ unsigned int sigarg;
+ unsigned int sigargval;
+};
+
+struct cond_subtests {
+ unsigned int num;
+ const struct cond_sigargs sigargs[];
+};
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 {
/* DEC Ada specific conditions. */
static const struct cond_except dec_ada_cond_except_table [] = {
- {ADA$_PROGRAM_ERROR, &program_error},
- {ADA$_USE_ERROR, &Use_Error},
- {ADA$_KEYSIZERR, &program_error},
- {ADA$_STAOVF, &storage_error},
- {ADA$_CONSTRAINT_ERRO, &constraint_error},
- {ADA$_IOSYSFAILED, &Device_Error},
- {ADA$_LAYOUT_ERROR, &Layout_Error},
- {ADA$_STORAGE_ERROR, &storage_error},
- {ADA$_DATA_ERROR, &Data_Error},
- {ADA$_DEVICE_ERROR, &Device_Error},
- {ADA$_END_ERROR, &End_Error},
- {ADA$_MODE_ERROR, &Mode_Error},
- {ADA$_NAME_ERROR, &Name_Error},
- {ADA$_STATUS_ERROR, &Status_Error},
- {ADA$_NOT_OPEN, &Use_Error},
- {ADA$_ALREADY_OPEN, &Use_Error},
- {ADA$_USE_ERROR, &Use_Error},
- {ADA$_UNSUPPORTED, &Use_Error},
- {ADA$_FAC_MODE_MISMAT, &Use_Error},
- {ADA$_ORG_MISMATCH, &Use_Error},
- {ADA$_RFM_MISMATCH, &Use_Error},
- {ADA$_RAT_MISMATCH, &Use_Error},
- {ADA$_MRS_MISMATCH, &Use_Error},
- {ADA$_MRN_MISMATCH, &Use_Error},
- {ADA$_KEY_MISMATCH, &Use_Error},
- {ADA$_MAXLINEXC, &constraint_error},
- {ADA$_LINEXCMRS, &constraint_error},
+ {ADA$_PROGRAM_ERROR, &program_error, 0, 0},
+ {ADA$_USE_ERROR, &Use_Error, 0, 0},
+ {ADA$_KEYSIZERR, &program_error, 0, 0},
+ {ADA$_STAOVF, &storage_error, 0, 0},
+ {ADA$_CONSTRAINT_ERRO, &constraint_error, 0, 0},
+ {ADA$_IOSYSFAILED, &Device_Error, 0, 0},
+ {ADA$_LAYOUT_ERROR, &Layout_Error, 0, 0},
+ {ADA$_STORAGE_ERROR, &storage_error, 0, 0},
+ {ADA$_DATA_ERROR, &Data_Error, 0, 0},
+ {ADA$_DEVICE_ERROR, &Device_Error, 0, 0},
+ {ADA$_END_ERROR, &End_Error, 0, 0},
+ {ADA$_MODE_ERROR, &Mode_Error, 0, 0},
+ {ADA$_NAME_ERROR, &Name_Error, 0, 0},
+ {ADA$_STATUS_ERROR, &Status_Error, 0, 0},
+ {ADA$_NOT_OPEN, &Use_Error, 0, 0},
+ {ADA$_ALREADY_OPEN, &Use_Error, 0, 0},
+ {ADA$_USE_ERROR, &Use_Error, 0, 0},
+ {ADA$_UNSUPPORTED, &Use_Error, 0, 0},
+ {ADA$_FAC_MODE_MISMAT, &Use_Error, 0, 0},
+ {ADA$_ORG_MISMATCH, &Use_Error, 0, 0},
+ {ADA$_RFM_MISMATCH, &Use_Error, 0, 0},
+ {ADA$_RAT_MISMATCH, &Use_Error, 0, 0},
+ {ADA$_MRS_MISMATCH, &Use_Error, 0, 0},
+ {ADA$_MRN_MISMATCH, &Use_Error, 0, 0},
+ {ADA$_KEY_MISMATCH, &Use_Error, 0, 0},
+ {ADA$_MAXLINEXC, &constraint_error, 0, 0},
+ {ADA$_LINEXCMRS, &constraint_error, 0, 0},
#if 0
/* Already handled by a pragma Import_Exception
in Aux_IO_Exceptions */
- {ADA$_LOCK_ERROR, &Lock_Error},
- {ADA$_EXISTENCE_ERROR, &Existence_Error},
- {ADA$_KEY_ERROR, &Key_Error},
+ {ADA$_LOCK_ERROR, &Lock_Error, 0, 0},
+ {ADA$_EXISTENCE_ERROR, &Existence_Error, 0, 0},
+ {ADA$_KEY_ERROR, &Key_Error, 0, 0},
#endif
- {0, 0}
+ {0, 0, 0, 0}
};
#endif /* IN_RTS */
-/* Non-DEC Ada specific conditions. We could probably also put
- SS$_HPARITH here and possibly SS$_ACCVIO, SS$_STKOVF. */
-static const struct cond_except cond_except_table [] = {
- {MTH$_FLOOVEMAT, &constraint_error},
- {SS$_INTDIV, &constraint_error},
- {0, 0}
+/* Non-DEC Ada specific conditions that map to Ada exceptions. */
+
+/* Subtest for ACCVIO Constraint_Error, kept for compatibility,
+ in hindsight should have just made ACCVIO == Storage_Error. */
+#define ACCVIO_REASON_MASK 2
+#define ACCVIO_VIRTUAL_ADDR 3
+static const struct cond_subtests accvio_c_e =
+ {2, /* number of subtests below */
+ {
+ {ACCVIO_REASON_MASK, 0},
+ {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 [] = {
+ {MTH$_FLOOVEMAT, &constraint_error, 0, 0},
+ {SS$_INTDIV, &constraint_error, 0, 0},
+ {SS$_HPARITH, &constraint_error, NEEDS_ADJUST, 0},
+ {SS$_ACCVIO, &constraint_error, NEEDS_ADJUST, &accvio_c_e},
+ {SS$_ACCVIO, &storage_error, NEEDS_ADJUST, 0},
+ {SS$_STKOVF, &storage_error, NEEDS_ADJUST, 0},
+ {0, 0, 0, 0}
};
/* To deal with VMS conditions and their mapping to Ada exceptions,
for (i = 0, iexcept = 0;
cond_resignal_table [i]
- && !(iexcept = LIB$MATCH_COND (&code, &cond_resignal_table [i]));
+ && !(iexcept = LIB$MATCH_COND (&code, &cond_resignal_table [i]));
i++);
return iexcept;
return 0;
}
+/* 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 [])
+{
+ int i;
+ struct cond_except entry;
+
+ /* Scan the exception condition table for a match and fetch
+ the associated GNAT exception pointer. */
+ for (i = 0; (*table) [i].cond; i++)
+ {
+ unsigned int match = LIB$MATCH_COND (&sigargs [1], &(*table) [i].cond);
+ const struct cond_subtests *subtests = (*table) [i].subtests;
+
+ if (match)
+ {
+ if (!subtests)
+ {
+ return &(*table) [i];
+ }
+ else
+ {
+ unsigned int ii;
+ int num = (*subtests).num;
+
+ /* Perform subtests to differentiate exception. */
+ for (ii = 0; ii < num; ii++)
+ {
+ unsigned int arg = (*subtests).sigargs [ii].sigarg;
+ unsigned int argval = (*subtests).sigargs [ii].sigargval;
+
+ if (sigargs [arg] != argval)
+ {
+ num = 0;
+ break;
+ }
+ }
+
+ /* All subtests passed. */
+ if (num == (*subtests).num)
+ return &(*table) [i];
+ }
+ }
+ }
+
+ /* No match, return the null terminating entry. */
+ return &(*table) [i];
+}
+
long
__gnat_handle_vms_condition (int *sigargs, void *mechargs)
{
struct Exception_Data *exception = 0;
+ unsigned int needs_adjust = 0;
Exception_Code base_code;
struct descriptor_s gnat_facility = {4, 0, "GNAT"};
char message [Default_Exception_Msg_Max_Length];
Import_Exception. */
if (__gnat_resignal_p (sigargs [1]))
return SS$_RESIGNAL;
+#ifndef IN_RTS
+ /* toplev.c handles this for compiler. */
+ if (sigargs [1] == SS$_HPARITH)
+ return SS$_RESIGNAL;
+#endif
#ifdef IN_RTS
/* See if it's an imported exception. Beware that registered exceptions
are bound to their base code, with the severity bits masked off. */
base_code = Base_Code_In ((Exception_Code) sigargs[1]);
exception = Coded_Exception (base_code);
-
- if (exception)
- {
- message[0] = 0;
-
- /* Subtract PC & PSL fields which messes with PUTMSG. */
- sigargs[0] -= 2;
- SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message);
- sigargs[0] += 2;
- msg = message;
-
- exception->Name_Length = 19;
- /* ??? The full name really should be get SYS$GETMSG returns. */
- exception->Full_Name = "IMPORTED_EXCEPTION";
- exception->Import_Code = base_code;
-
-#ifdef __IA64
- /* Do not adjust the program counter as already points to the next
- instruction (just after the call to LIB$STOP). */
- Raise_From_Signal_Handler (exception, msg);
-#endif
- }
#endif
if (exception == 0)
- switch (sigargs[1])
- {
- case SS$_ACCVIO:
- if (sigargs[3] == 0)
- {
- exception = &constraint_error;
- msg = "access zero";
- }
- else
- {
- exception = &storage_error;
- msg = "stack overflow or erroneous memory access";
- }
- __gnat_adjust_context_for_raise (SS$_ACCVIO, (void *)mechargs);
- break;
-
- case SS$_STKOVF:
- exception = &storage_error;
- msg = "stack overflow";
- __gnat_adjust_context_for_raise (SS$_STKOVF, (void *)mechargs);
- break;
-
- case SS$_HPARITH:
-#ifndef IN_RTS
- return SS$_RESIGNAL; /* toplev.c handles for compiler */
-#else
- exception = &constraint_error;
- msg = "arithmetic error";
- __gnat_adjust_context_for_raise (SS$_HPARITH, (void *)mechargs);
-#endif
- break;
-
- default:
#ifdef IN_RTS
+ {
+ int i;
+ struct cond_except cond;
+ const struct cond_except *cond_table;
+ const struct cond_except *cond_tables [] = {dec_ada_cond_except_table,
+ system_cond_except_table,
+ 0};
+
+ i = 0;
+ while ((cond_table = cond_tables[i++]) && !exception)
{
- int i;
-
- /* Scan the DEC Ada exception condition table for a match and fetch
- the associated GNAT exception pointer. */
- for (i = 0;
- dec_ada_cond_except_table [i].cond &&
- !LIB$MATCH_COND (&sigargs [1],
- &dec_ada_cond_except_table [i].cond);
- i++);
- exception = (struct Exception_Data *)
- dec_ada_cond_except_table [i].except;
-
- if (!exception)
- {
- /* Scan the VMS standard condition table for a match and fetch
- the associated GNAT exception pointer. */
- for (i = 0;
- cond_except_table[i].cond &&
- !LIB$MATCH_COND (&sigargs[1], &cond_except_table[i].cond);
- i++);
- exception = (struct Exception_Data *)
- cond_except_table [i].except;
-
- if (!exception)
- /* User programs expect Non_Ada_Error to be raised, reference
- DEC Ada test CXCONDHAN. */
- exception = &Non_Ada_Error;
- }
+ cond = *scan_conditions (sigargs, &cond_table);
+ exception = (struct Exception_Data *) cond.except;
}
+
+ if (exception)
+ needs_adjust = cond.needs_adjust;
+ else
+ /* User programs expect Non_Ada_Error to be raised if no match,
+ reference DEC Ada test CXCONDHAN. */
+ exception = &Non_Ada_Error;
+ }
#else
- exception = &program_error;
+ {
+ /* Pretty much everything is just a program error in the compiler */
+ exception = &program_error;
+ }
#endif
- message[0] = 0;
- /* Subtract PC & PSL fields which messes with PUTMSG. */
- sigargs[0] -= 2;
- SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message);
- sigargs[0] += 2;
- msg = message;
- break;
- }
+
+ message[0] = 0;
+ /* Subtract PC & PSL fields as per ABI for SYS$PUTMSG. */
+ sigargs[0] -= 2;
+ SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message);
+ /* Add back PC & PSL fields as per ABI for SYS$PUTMSG. */
+ sigargs[0] += 2;
+ msg = message;
+
+ if (needs_adjust)
+ __gnat_adjust_context_for_raise (sigargs [1], (void *)mechargs);
Raise_From_Signal_Handler (exception, msg);
}
if (signo == SS$_HPARITH)
{
/* Sub one to the address of the instruction signaling the condition,
- located in the sigargs array. */
+ located in the sigargs array. */
CHF$MECH_ARRAY * mechargs = (CHF$MECH_ARRAY *) ucontext;
CHF$SIGNAL_ARRAY * sigargs
- = (CHF$SIGNAL_ARRAY *) mechargs->chf$q_mch_sig_addr;
+ = (CHF$SIGNAL_ARRAY *) mechargs->chf$q_mch_sig_addr;
int vcount = sigargs->chf$is_sig_args;
int * pc_slot = & (&sigargs->chf$l_sig_name)[vcount-2];
projects / thirdparty / gcc.git / commitdiff
