2002-03-07 Geert Bosch <bosch@gnat.com>
+ * adadecode.c, adadecode.h, aux-io.c, s-traces.adb, s-traces.ads,
+ s-tratas.adb, s-tratas.ads, sinput-d.adb, sinput-d.ads,
+ switch-b.adb, switch-b.ads, switch-c.adb, switch-c.ads,
+ switch-m.adb, switch-m.ads : New files.
+
+2002-03-07 Geert Bosch <bosch@gnat.com>
+
* 41intnam.ads, 42intnam.ads, 4aintnam.ads, 4cintnam.ads,
4dintnam.ads, 4gintnam.ads, 4hintnam.ads, 4lintnam.ads,
4mintnam.ads, 4pintnam.ads, 4rintnam.ads, 4sintnam.ads,
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * G N A T D E C O *
+ * *
+ * $Revision$
+ * *
+ * C Implementation File *
+ * *
+ * Copyright (C) 2001-2002, 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 2, 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. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * As a special exception, if you link this file with other files to *
+ * produce an executable, this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not however invalidate any other reasons why the executable *
+ * file might be covered by the GNU Public License. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ * *
+ ****************************************************************************/
+
+#ifdef IN_GCC
+#include "config.h"
+#include "system.h"
+#else
+#include <stdio.h>
+#define PARMS(ARGS) ARGS
+#endif
+
+#include "ctype.h"
+#include "adadecode.h"
+
+static void add_verbose PARAMS ((const char *, char *));
+static int has_prefix PARAMS ((char *, const char *));
+static int has_suffix PARAMS ((char *, const char *));
+
+/* Set to nonzero if we have written any verbose info. */
+static int verbose_info;
+
+/* Add TEXT to end of ADA_NAME, putting a leading " (" or ", ", depending
+ on VERBOSE_INFO. */
+
+static void add_verbose (text, ada_name)
+ const char *text;
+ char *ada_name;
+{
+ strcat (ada_name, verbose_info ? ", " : " (");
+ strcat (ada_name, text);
+
+ verbose_info = 1;
+}
+
+/* Returns 1 if NAME starts with PREFIX. */
+
+static int
+has_prefix (name, prefix)
+ char *name;
+ const char *prefix;
+{
+ return strncmp (name, prefix, strlen (prefix)) == 0;
+}
+
+/* Returns 1 if NAME ends with SUFFIX. */
+
+static int
+has_suffix (name, suffix)
+ char *name;
+ const char *suffix;
+{
+ int nlen = strlen (name);
+ int slen = strlen (suffix);
+
+ return nlen > slen && strncmp (name + nlen - slen, suffix, slen) == 0;
+}
+
+/* This function will return the Ada name from the encoded form.
+ The Ada coding is done in exp_dbug.ads and this is the inverse function.
+ see exp_dbug.ads for full encoding rules, a short description is added
+ below. Right now only objects and routines are handled. There is no support
+ for Ada types.
+
+ CODED_NAME is the encoded entity name.
+
+ ADA_NAME is a pointer to a buffer, it will receive the Ada name. A safe
+ size for this buffer is: strlen (coded_name) * 2 + 60. (60 is for the
+ verbose information).
+
+ VERBOSE is nonzero if more information about the entity is to be
+ added at the end of the Ada name and surrounded by ( and ).
+
+ Coded name Ada name verbose info
+ ---------------------------------------------------------------------
+ _ada_xyz xyz library level
+ x__y__z x.y.z
+ x__yTKB x.y task body
+ x__yB x.y task body
+ x__yX x.y body nested
+ x__yXb x.y body nested
+ xTK__y x.y in task
+ x__y$2 x.y overloaded
+ x__y__3 x.y overloaded
+ x__Oabs "abs"
+ x__Oand "and"
+ x__Omod "mod"
+ x__Onot "not"
+ x__Oor "or"
+ x__Orem "rem"
+ x__Oxor "xor"
+ x__Oeq "="
+ x__One "/="
+ x__Olt "<"
+ x__Ole "<="
+ x__Ogt ">"
+ x__Oge ">="
+ x__Oadd "+"
+ x__Osubtract "-"
+ x__Oconcat "&"
+ x__Omultiply "*"
+ x__Odivide "/"
+ x__Oexpon "**" */
+
+void
+__gnat_decode (coded_name, ada_name, verbose)
+ const char *coded_name;
+ char *ada_name;
+ int verbose;
+{
+ int lib_subprog = 0;
+ int overloaded = 0;
+ int task_body = 0;
+ int in_task = 0;
+ int body_nested = 0;
+
+ /* Copy the coded name into the ada name string, the rest of the code will
+ just replace or add characters into the ada_name. */
+ strcpy (ada_name, coded_name);
+
+ /* Check for library level subprogram. */
+ if (has_prefix (ada_name, "_ada_"))
+ {
+ strcpy (ada_name, ada_name + 5);
+ lib_subprog = 1;
+ }
+
+ /* Check for task body. */
+ if (has_suffix (ada_name, "TKB"))
+ {
+ ada_name[strlen (ada_name) - 3] = '\0';
+ task_body = 1;
+ }
+
+ if (has_suffix (ada_name, "B"))
+ {
+ ada_name[strlen (ada_name) - 1] = '\0';
+ task_body = 1;
+ }
+
+ /* Check for body-nested entity: X[bn] */
+ if (has_suffix (ada_name, "X"))
+ {
+ ada_name[strlen (ada_name) - 1] = '\0';
+ body_nested = 1;
+ }
+
+ if (has_suffix (ada_name, "Xb"))
+ {
+ ada_name[strlen (ada_name) - 2] = '\0';
+ body_nested = 1;
+ }
+
+ if (has_suffix (ada_name, "Xn"))
+ {
+ ada_name[strlen (ada_name) - 2] = '\0';
+ body_nested = 1;
+ }
+
+ /* Change instance of TK__ (object declared inside a task) to __. */
+ {
+ char *tktoken;
+
+ while ((tktoken = (char *) strstr (ada_name, "TK__")) != NULL)
+ {
+ strcpy (tktoken, tktoken + 2);
+ in_task = 1;
+ }
+ }
+
+ /* Check for overloading: name terminated by $nn or __nn. */
+ {
+ int len = strlen (ada_name);
+ int n_digits = 0;
+
+ if (len > 1)
+ while (isdigit ((int) ada_name[(int) len - 1 - n_digits]))
+ n_digits++;
+
+ /* Check if we have $ or __ before digits. */
+ if (ada_name[len - 1 - n_digits] == '$')
+ {
+ ada_name[len - 1 - n_digits] = '\0';
+ overloaded = 1;
+ }
+ else if (ada_name[len - 1 - n_digits] == '_'
+ && ada_name[len - 1 - n_digits - 1] == '_')
+ {
+ ada_name[len - 1 - n_digits - 1] = '\0';
+ overloaded = 1;
+ }
+ }
+
+ /* Change all "__" to ".". */
+ {
+ int len = strlen (ada_name);
+ int k = 0;
+
+ while (k < len)
+ {
+ if (ada_name[k] == '_' && ada_name[k+1] == '_')
+ {
+ ada_name[k] = '.';
+ strcpy (ada_name + k + 1, ada_name + k + 2);
+ len = len - 1;
+ }
+ k++;
+ }
+ }
+
+ /* Checks for operator name. */
+ {
+ const char *trans_table[][2]
+ = {{"Oabs", "\"abs\""}, {"Oand", "\"and\""}, {"Omod", "\"mod\""},
+ {"Onot", "\"not\""}, {"Oor", "\"or\""}, {"Orem", "\"rem\""},
+ {"Oxor", "\"xor\""}, {"Oeq", "\"=\""}, {"One", "\"/=\""},
+ {"Olt", "\"<\""}, {"Ole", "\"<=\""}, {"Ogt", "\">\""},
+ {"Oge", "\">=\""}, {"Oadd", "\"+\""}, {"Osubtract", "\"-\""},
+ {"Oconcat", "\"&\""}, {"Omultiply", "\"*\""}, {"Odivide", "\"/\""},
+ {"Oexpon", "\"**\""}, {NULL, NULL} };
+ int k = 0;
+
+ while (1)
+ {
+ char *optoken;
+
+ if ((optoken = (char *) strstr (ada_name, trans_table[k][0])) != NULL)
+ {
+ int codedlen = strlen (trans_table[k][0]);
+ int oplen = strlen (trans_table[k][1]);
+
+ if (codedlen > oplen)
+ /* We shrink the space. */
+ strcpy (optoken, optoken + codedlen - oplen);
+ else if (oplen > codedlen)
+ {
+ /* We need more space. */
+ int len = strlen (ada_name);
+ int space = oplen - codedlen;
+ int num_to_move = &ada_name[len] - optoken;
+ int t;
+
+ for (t = 0; t < num_to_move; t++)
+ ada_name[len + space - t - 1] = ada_name[len - t - 1];
+ }
+
+ /* Write symbol in the space. */
+ strncpy (optoken, trans_table[k][1], oplen);
+ }
+ else
+ k++;
+
+ /* Check for table's ending. */
+ if (trans_table[k][0] == NULL)
+ break;
+ }
+ }
+
+ /* If verbose mode is on, we add some information to the Ada name. */
+ if (verbose)
+ {
+ if (overloaded)
+ add_verbose ("overloaded", ada_name);
+
+ if (lib_subprog)
+ add_verbose ("library level", ada_name);
+
+ if (body_nested)
+ add_verbose ("body nested", ada_name);
+
+ if (in_task)
+ add_verbose ("in task", ada_name);
+
+ if (task_body)
+ add_verbose ("task body", ada_name);
+
+ if (verbose_info == 1)
+ strcat (ada_name, ")");
+ }
+}
+
+char *
+ada_demangle (coded_name)
+ const char *coded_name;
+{
+ char ada_name[2048];
+ char *result;
+
+ __gnat_decode (coded_name, ada_name, 0);
+
+ result = (char *) xmalloc (strlen (ada_name) + 1);
+ strcpy (result, ada_name);
+
+ return result;
+}
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * G N A T D E C O *
+ * *
+ * $Revision$
+ * *
+ * C Header File *
+ * *
+ * Copyright (C) 2001-2002, 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 2, 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. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * As a special exception, if you link this file with other files to *
+ * produce an executable, this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not however invalidate any other reasons why the executable *
+ * file might be covered by the GNU Public License. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ * *
+ ****************************************************************************/
+
+/* This function will return the Ada name from the encoded form.
+ The Ada coding is done in exp_dbug.ads and this is the inverse function.
+ see exp_dbug.ads for full encoding rules, a short description is added
+ below. Right now only objects and routines are handled. There is no support
+ for Ada types.
+
+ CODED_NAME is the encoded entity name.
+ ADA_NAME is a pointer to a buffer, it will receive the Ada name. A safe
+ size for this buffer is: strlen (coded_name) * 2 + 60. (60 is for the
+ verbose information).
+ VERBOSE is nonzero if more information about the entity is to be
+ added at the end of the Ada name and surrounded by ( and ). */
+extern void __gnat_decode PARAMS ((const char *, char *, int));
+
+/* ada_demangle is added for COMPATIBILITY ONLY. It has the name of the
+ function used in the binutils and GDB. Always consider using __gnat_decode
+ instead of ada_demangle. Caller must free the pointer returned. */
+extern char *ada_demangle PARAMS ((const char *));
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT RUN-TIME COMPONENTS *
+ * *
+ * A - T R A N S *
+ * *
+ * C Implementation File *
+ * *
+ * $Revision$
+ * *
+ * Copyright (C) 1992-2001 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 2, 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. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * As a special exception, if you link this file with other files to *
+ * produce an executable, this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not however invalidate any other reasons why the executable *
+ * file might be covered by the GNU Public License. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ * *
+ ****************************************************************************/
+
+#include <stdio.h>
+
+#ifdef IN_RTS
+#include "tconfig.h"
+#include "tsystem.h"
+#else
+#include "config.h"
+#include "system.h"
+#endif
+
+/* Function wrappers are needed to access the values from Ada which are
+ defined as C macros. */
+
+FILE *c_stdin PARAMS ((void));
+FILE *c_stdout PARAMS ((void));
+FILE *c_stderr PARAMS ((void));
+int seek_set_function PARAMS ((void));
+int seek_end_function PARAMS ((void));
+void *null_function PARAMS ((void));
+int c_fileno PARAMS ((FILE *));
+
+FILE *
+c_stdin ()
+{
+ return stdin;
+}
+
+FILE *
+c_stdout ()
+{
+ return stdout;
+}
+
+FILE *
+c_stderr ()
+{
+ return stderr;
+}
+
+#ifndef SEEK_SET /* Symbolic constants for the "fseek" function: */
+#define SEEK_SET 0 /* Set file pointer to offset */
+#define SEEK_CUR 1 /* Set file pointer to its current value plus offset */
+#define SEEK_END 2 /* Set file pointer to the size of the file plus offset */
+#endif
+
+int
+seek_set_function ()
+{
+ return SEEK_SET;
+}
+
+int
+seek_end_function ()
+{
+ return SEEK_END;
+}
+
+void *null_function ()
+{
+ return NULL;
+}
+
+int
+c_fileno (s)
+ FILE *s;
+{
+ return fileno (s);
+}
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E S --
+-- --
+-- B o d y --
+-- --
+-- $Revision$
+-- --
+-- Copyright (C) 2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Traces is
+
+ pragma Warnings (Off); -- kill warnings on unreferenced formals
+
+ ---------------------
+ -- Send_Trace_Info --
+ ---------------------
+
+ procedure Send_Trace_Info (Id : Trace_T) is
+ begin
+ null;
+ end Send_Trace_Info;
+
+ ---------------------
+ -- Send_Trace_Info --
+ ---------------------
+
+ procedure Send_Trace_Info (Id : Trace_T; Timeout : Duration) is
+ begin
+ null;
+ end Send_Trace_Info;
+
+end System.Traces;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision$
+-- --
+-- Copyright (C) 2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package implements functions for traces when tasking is not involved
+
+-- Warning : NO dependencies to tasking should be created here
+
+-- This package, and all its children are used to implement debug
+-- informations
+
+-- A new primitive, Send_Trace_Info (Id : Trace_T; 'data') is introduced.
+-- Trace_T is an event identifier, 'data' are the informations to pass
+-- with the event. Thid procedure is used from within the Runtime to send
+-- debug informations.
+
+-- This primitive is overloaded in System.Traces.Tasking and this package.
+
+-- Send_Trace_Info calls Send_Trace, in System.Traces.Send, which is trarget
+-- dependent, to send the debug informations to a debugger, stream ..
+
+-- To add a new event, just add them to the Trace_T type, and write the
+-- corresponding Send_Trace_Info procedure. It may be required for some
+-- target to modify Send_Trace (eg. VxWorks).
+
+-- To add a new target, just adapt System.Traces.Send to your own purpose.
+
+package System.Traces is
+
+ type Trace_T is
+ (
+ -- Events handled.
+
+ -- Messages
+ --
+ M_Accept_Complete,
+ M_Select_Else,
+ M_RDV_Complete,
+ M_Call_Complete,
+ M_Delay,
+
+ -- Errors
+ --
+ E_Missed,
+ E_Timeout,
+ E_Kill,
+
+ -- Waiting events
+ --
+ W_Call,
+ W_Accept,
+ W_Select,
+ W_Completion,
+ W_Delay,
+ WU_Delay,
+
+ WT_Call,
+ WT_Select,
+ WT_Completion,
+
+ -- Protected objects events
+ --
+ PO_Call,
+ POT_Call,
+ PO_Run,
+ PO_Lock,
+ PO_Unlock,
+ PO_Done,
+
+ -- Task handling events
+ --
+ T_Create,
+ T_Activate,
+ T_Abort,
+ T_Terminate);
+
+ -- Send_Trace_Info procedures
+
+ -- They are overloaded, depending on the parameters passed with
+ -- the event, e.g. Time information, Task name, Accept name ...
+
+ procedure Send_Trace_Info (Id : Trace_T);
+
+ procedure Send_Trace_Info (Id : Trace_T; Timeout : Duration);
+
+end System.Traces;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E S . T A S K I N G --
+-- --
+-- B o d y --
+-- --
+-- $Revision$
+-- --
+-- Copyright (C) 2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Traces.Tasking is
+
+ pragma Warnings (Off); -- kill warnings on unreferenced formals
+
+ ---------------------
+ -- Send_Trace_Info --
+ ---------------------
+
+ procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : ST.Task_ID) is
+ begin
+ null;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name2 : ST.Task_ID;
+ Entry_Number : ST.Entry_Index)
+ is
+ begin
+ null;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name : ST.Task_ID;
+ Task_Name2 : ST.Task_ID;
+ Entry_Number : ST.Entry_Index)
+ is
+ begin
+ null;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name : ST.Task_ID;
+ Task_Name2 : ST.Task_ID)
+ is
+ begin
+ null;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Entry_Number : ST.Entry_Index)
+ is
+ begin
+ null;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Acceptor : ST.Task_ID;
+ Entry_Number : ST.Entry_Index;
+ Timeout : Duration)
+ is
+ begin
+ null;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Entry_Number : ST.Entry_Index;
+ Timeout : Duration)
+ is
+ begin
+ null;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name : ST.Task_ID;
+ Number : Integer)
+ is
+ begin
+ null;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name : ST.Task_ID;
+ Number : Integer;
+ Timeout : Duration)
+ is
+ begin
+ null;
+ end Send_Trace_Info;
+
+end System.Traces.Tasking;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E S . T A S K I N G --
+-- --
+-- S p e c --
+-- --
+-- $Revision$
+-- --
+-- Copyright (C) 2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides all procedures used to implement debug traces
+-- in the case tasking is involved.
+
+-- See System.Traces for an overview of the various files involved in Tracing
+
+-- If tasking is not involved, refer to System.Traces.General
+
+with System.Tasking;
+
+package System.Traces.Tasking is
+
+ package ST renames System.Tasking;
+
+ -- Send_Trace_Info procedures
+
+ -- They are overloaded, depending on the parameters passed with the event
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name2 : ST.Task_ID);
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name2 : ST.Task_ID;
+ Entry_Number : ST.Entry_Index);
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name : ST.Task_ID;
+ Task_Name2 : ST.Task_ID;
+ Entry_Number : ST.Entry_Index);
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name : ST.Task_ID;
+ Task_Name2 : ST.Task_ID);
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Entry_Number : ST.Entry_Index);
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Acceptor : ST.Task_ID;
+ Entry_Number : ST.Entry_Index;
+ Timeout : Duration);
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Entry_Number : ST.Entry_Index;
+ Timeout : Duration);
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name : ST.Task_ID;
+ Number : Integer);
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name : ST.Task_ID;
+ Number : Integer;
+ Timeout : Duration);
+end System.Traces.Tasking;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N P U T . D --
+-- --
+-- B o d y --
+-- --
+-- $Revision$
+-- --
+-- Copyright (C) 2001, 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 2, 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Osint; use Osint;
+with Osint.C; use Osint.C;
+
+package body Sinput.D is
+
+ Dfile : Source_File_Index;
+ -- Index of currently active debug source file
+
+ ------------------------
+ -- Close_Debug_Source --
+ ------------------------
+
+ procedure Close_Debug_Source is
+ S : Source_File_Record renames Source_File.Table (Dfile);
+ Src : Source_Buffer_Ptr;
+
+ begin
+ Trim_Lines_Table (Dfile);
+ Close_Debug_File;
+
+ -- Now we need to read the file that we wrote and store it
+ -- in memory for subsequent access.
+
+ Read_Source_File
+ (S.Debug_Source_Name, S.Source_First, S.Source_Last, Src);
+ S.Source_Text := Src;
+ end Close_Debug_Source;
+
+ -------------------------
+ -- Create_Debug_Source --
+ -------------------------
+
+ procedure Create_Debug_Source
+ (Source : Source_File_Index;
+ Loc : out Source_Ptr)
+ is
+ begin
+ Loc := Source_File.Table (Source_File.Last).Source_Last + 1;
+ Source_File.Increment_Last;
+ Dfile := Source_File.Last;
+
+ declare
+ S : Source_File_Record renames Source_File.Table (Dfile);
+
+ begin
+ S := Source_File.Table (Source);
+ S.Debug_Source_Name := Create_Debug_File (S.File_Name);
+ S.Source_First := Loc;
+ S.Source_Last := Loc;
+ S.Lines_Table := null;
+ S.Last_Source_Line := 1;
+
+ -- Allocate lines table, guess that it needs to be three times
+ -- bigger than the original source (in number of lines).
+
+ Alloc_Line_Tables
+ (S, Int (Source_File.Table (Source).Last_Source_Line * 3));
+ S.Lines_Table (1) := Loc;
+ end;
+ end Create_Debug_Source;
+
+ ----------------------
+ -- Write_Debug_Line --
+ ----------------------
+
+ procedure Write_Debug_Line (Str : String; Loc : in out Source_Ptr) is
+ S : Source_File_Record renames Source_File.Table (Dfile);
+
+ begin
+ -- Ignore write request if null line at start of file
+
+ if Str'Length = 0 and then Loc = S.Source_First then
+ return;
+
+ -- Here we write the line, and update the source record entry
+
+ else
+ Write_Debug_Info (Str (Str'First .. Str'Last - 1));
+ Add_Line_Tables_Entry (S, Loc);
+ Loc := Loc - 1 + Source_Ptr (Str'Length + Debug_File_Eol_Length);
+ S.Source_Last := Loc;
+ end if;
+ end Write_Debug_Line;
+
+end Sinput.D;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N P U T . D --
+-- --
+-- S p e c --
+-- --
+-- $Revision$
+-- --
+-- Copyright (C) 2001, 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 2, 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This child package contains the routines used to write debug source
+-- files. These routines are not in Sinput.L, because they are used only
+-- by the compiler, while Sinput.L is also used by gnatmake.
+
+package Sinput.D is
+
+ ------------------------------------------------
+ -- Subprograms for Writing Debug Source Files --
+ ------------------------------------------------
+
+ procedure Create_Debug_Source
+ (Source : Source_File_Index;
+ Loc : out Source_Ptr);
+ -- Given a source file, creates a new source file table entry to be used
+ -- for the debug source file output (Debug_Generated_Code switch set).
+ -- Loc is set to the initial Sloc value for the first line. This call
+ -- also creates the debug source output file (using Create_Debug_File).
+
+ procedure Write_Debug_Line (Str : String; Loc : in out Source_Ptr);
+ -- This procedure is called to write a line to the debug source file
+ -- previously created by Create_Debug_Source using Write_Debug_Info.
+ -- Str is the source line to be written to the file (it does not include
+ -- an end of line character). On entry Loc is the Sloc value previously
+ -- returned by Create_Debug_Source or Write_Debug_Line, and on exit,
+ -- Sloc is updated to point to the start of the next line to be written,
+ -- taking into account the length of the ternminator that was written by
+ -- Write_Debug_Info.
+
+ procedure Close_Debug_Source;
+ -- This procedure completes the source table entry for the debug file
+ -- previously created by Create_Debug_Source, and written using the
+ -- Write_Debug_Line procedure. It then calls Close_Debug_File to
+ -- complete the writing of the file itself.
+
+end Sinput.D;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S W I T C H - B --
+-- --
+-- B o d y --
+-- --
+-- $Revision$
+-- --
+-- Copyright (C) 2001-2002 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 2, 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Debug; use Debug;
+with Osint; use Osint;
+with Opt; use Opt;
+
+with System.WCh_Con; use System.WCh_Con;
+
+package body Switch.B is
+
+ --------------------------
+ -- Scan_Binder_Switches --
+ --------------------------
+
+ procedure Scan_Binder_Switches (Switch_Chars : String) is
+ Ptr : Integer := Switch_Chars'First;
+ Max : Integer := Switch_Chars'Last;
+ C : Character := ' ';
+
+ begin
+ -- Skip past the initial character (must be the switch character)
+
+ if Ptr = Max then
+ raise Bad_Switch;
+ else
+ Ptr := Ptr + 1;
+ end if;
+
+ -- A little check, "gnat" at the start of a switch is not allowed
+ -- except for the compiler
+
+ if Switch_Chars'Last >= Ptr + 3
+ and then Switch_Chars (Ptr .. Ptr + 3) = "gnat"
+ then
+ Osint.Fail ("invalid switch: """, Switch_Chars, """"
+ & " (gnat not needed here)");
+
+ end if;
+
+ -- Loop to scan through switches given in switch string
+
+ while Ptr <= Max loop
+ C := Switch_Chars (Ptr);
+
+ case C is
+
+ -- Processing for A switch
+
+ when 'A' =>
+ Ptr := Ptr + 1;
+
+ Ada_Bind_File := True;
+
+ -- Processing for b switch
+
+ when 'b' =>
+ Ptr := Ptr + 1;
+ Brief_Output := True;
+
+ -- Processing for c switch
+
+ when 'c' =>
+ Ptr := Ptr + 1;
+
+ Check_Only := True;
+
+ -- Processing for C switch
+
+ when 'C' =>
+ Ptr := Ptr + 1;
+
+ Ada_Bind_File := False;
+
+ -- Processing for d switch
+
+ when 'd' =>
+
+ -- Note: for the debug switch, the remaining characters in this
+ -- switch field must all be debug flags, since all valid switch
+ -- characters are also valid debug characters. This switch is not
+ -- documented on purpose because it is only used by the
+ -- implementors.
+
+ -- Loop to scan out debug flags
+
+ while Ptr < Max loop
+ Ptr := Ptr + 1;
+ C := Switch_Chars (Ptr);
+ exit when C = ASCII.NUL or else C = '/' or else C = '-';
+
+ if C in '1' .. '9' or else
+ C in 'a' .. 'z' or else
+ C in 'A' .. 'Z'
+ then
+ Set_Debug_Flag (C);
+ else
+ raise Bad_Switch;
+ end if;
+ end loop;
+
+ -- Make sure Zero_Cost_Exceptions is set if gnatdX set. This
+ -- is for backwards compatibility with old versions and usage.
+
+ if Debug_Flag_XX then
+ Zero_Cost_Exceptions_Set := True;
+ Zero_Cost_Exceptions_Val := True;
+ end if;
+
+ return;
+
+ -- Processing for e switch
+
+ when 'e' =>
+ Ptr := Ptr + 1;
+ Elab_Dependency_Output := True;
+
+ -- Processing for E switch
+
+ when 'E' =>
+ Ptr := Ptr + 1;
+ Exception_Tracebacks := True;
+
+ -- Processing for f switch
+
+ when 'f' =>
+ Ptr := Ptr + 1;
+ Force_RM_Elaboration_Order := True;
+
+ -- Processing for g switch
+
+ when 'g' =>
+ Ptr := Ptr + 1;
+
+ if Ptr <= Max then
+ C := Switch_Chars (Ptr);
+
+ if C in '0' .. '3' then
+ Debugger_Level :=
+ Character'Pos
+ (Switch_Chars (Ptr)) - Character'Pos ('0');
+ Ptr := Ptr + 1;
+ end if;
+
+ else
+ Debugger_Level := 2;
+ end if;
+
+ -- Processing for h switch
+
+ when 'h' =>
+ Ptr := Ptr + 1;
+ Usage_Requested := True;
+
+ -- Processing for i switch
+
+ when 'i' =>
+ if Ptr = Max then
+ raise Bad_Switch;
+ end if;
+
+ Ptr := Ptr + 1;
+ C := Switch_Chars (Ptr);
+
+ if C in '1' .. '5'
+ or else C = '8'
+ or else C = 'p'
+ or else C = 'f'
+ or else C = 'n'
+ or else C = 'w'
+ then
+ Identifier_Character_Set := C;
+ Ptr := Ptr + 1;
+ else
+ raise Bad_Switch;
+ end if;
+
+ -- Processing for K switch
+
+ when 'K' =>
+ Ptr := Ptr + 1;
+ Output_Linker_Option_List := True;
+
+ -- Processing for l switch
+
+ when 'l' =>
+ Ptr := Ptr + 1;
+ Elab_Order_Output := True;
+
+ -- Processing for m switch
+
+ when 'm' =>
+ Ptr := Ptr + 1;
+ Scan_Pos (Switch_Chars, Max, Ptr, Maximum_Errors);
+
+ -- Processing for n switch
+
+ when 'n' =>
+ Ptr := Ptr + 1;
+ Bind_Main_Program := False;
+
+ -- Note: The -L option of the binder also implies -n, so
+ -- any change here must also be reflected in the processing
+ -- for -L that is found in Gnatbind.Scan_Bind_Arg.
+
+ -- Processing for o switch
+
+ when 'o' =>
+ Ptr := Ptr + 1;
+
+ if Output_File_Name_Present then
+ raise Too_Many_Output_Files;
+
+ else
+ Output_File_Name_Present := True;
+ end if;
+
+ -- Processing for O switch
+
+ when 'O' =>
+ Ptr := Ptr + 1;
+ Output_Object_List := True;
+
+ -- Processing for p switch
+
+ when 'p' =>
+ Ptr := Ptr + 1;
+ Pessimistic_Elab_Order := True;
+
+ -- Processing for q switch
+
+ when 'q' =>
+ Ptr := Ptr + 1;
+ Quiet_Output := True;
+
+ -- Processing for r switch
+
+ when 'r' =>
+ Ptr := Ptr + 1;
+ List_Restrictions := True;
+
+ -- Processing for s switch
+
+ when 's' =>
+ Ptr := Ptr + 1;
+ All_Sources := True;
+ Check_Source_Files := True;
+
+ -- Processing for t switch
+
+ when 't' =>
+ Ptr := Ptr + 1;
+ Tolerate_Consistency_Errors := True;
+
+ -- Processing for T switch
+
+ when 'T' =>
+ Ptr := Ptr + 1;
+ Time_Slice_Set := True;
+ Scan_Nat (Switch_Chars, Max, Ptr, Time_Slice_Value);
+
+ -- Processing for v switch
+
+ when 'v' =>
+ Ptr := Ptr + 1;
+ Verbose_Mode := True;
+
+ -- Processing for w switch
+
+ when 'w' =>
+
+ -- For the binder we only allow suppress/error cases
+
+ Ptr := Ptr + 1;
+
+ case Switch_Chars (Ptr) is
+
+ when 'e' =>
+ Warning_Mode := Treat_As_Error;
+
+ when 's' =>
+ Warning_Mode := Suppress;
+
+ when others =>
+ raise Bad_Switch;
+ end case;
+
+ Ptr := Ptr + 1;
+
+ -- Processing for W switch
+
+ when 'W' =>
+ Ptr := Ptr + 1;
+
+ for J in WC_Encoding_Method loop
+ if Switch_Chars (Ptr) = WC_Encoding_Letters (J) then
+ Wide_Character_Encoding_Method := J;
+ exit;
+
+ elsif J = WC_Encoding_Method'Last then
+ raise Bad_Switch;
+ end if;
+ end loop;
+
+ Upper_Half_Encoding :=
+ Wide_Character_Encoding_Method in
+ WC_Upper_Half_Encoding_Method;
+
+ Ptr := Ptr + 1;
+
+ -- Processing for x switch
+
+ when 'x' =>
+ Ptr := Ptr + 1;
+ All_Sources := False;
+ Check_Source_Files := False;
+
+ -- Processing for z switch
+
+ when 'z' =>
+ Ptr := Ptr + 1;
+ No_Main_Subprogram := True;
+
+ -- Ignore extra switch character
+
+ when '/' =>
+ Ptr := Ptr + 1;
+
+ -- Ignore '-' extra switch caracter, only if it isn't followed by
+ -- 'RTS'. If it is, then we must process the 'RTS' switch
+
+ when '-' =>
+
+ if Ptr + 3 <= Max and then
+ Switch_Chars (Ptr + 1 .. Ptr + 3) = "RTS"
+ then
+ Ptr := Ptr + 1;
+
+ if Switch_Chars (Ptr + 3) /= '=' or else
+ (Switch_Chars (Ptr + 3) = '='
+ and then Ptr + 4 > Max)
+ then
+ Osint.Fail ("missing path for --RTS");
+ else
+
+ -- valid --RTS switch
+ Opt.No_Stdinc := True;
+ Opt.RTS_Switch := True;
+
+ declare
+ Src_Path_Name : String_Ptr := Get_RTS_Search_Dir
+ (Switch_Chars (Ptr + 4 .. Switch_Chars'Last), Include);
+ Lib_Path_Name : String_Ptr := Get_RTS_Search_Dir
+ (Switch_Chars (Ptr + 4 .. Switch_Chars'Last), Objects);
+ begin
+ if Src_Path_Name /= null and then
+ Lib_Path_Name /= null
+ then
+ Add_Search_Dirs (Src_Path_Name, Include);
+ Add_Search_Dirs (Lib_Path_Name, Objects);
+ -- we can exit as there can not be another switch
+ -- after --RTS
+ exit;
+ elsif Src_Path_Name = null
+ and Lib_Path_Name = null then
+ Osint.Fail ("RTS path not valid: missing " &
+ "adainclude and adalib directories");
+ elsif Src_Path_Name = null then
+ Osint.Fail ("RTS path not valid: missing " &
+ "adainclude directory");
+ elsif Lib_Path_Name = null then
+ Osint.Fail ("RTS path not valid: missing " &
+ "adalib directory");
+ end if;
+ end;
+ end if;
+
+ else
+ Ptr := Ptr + 1;
+ end if;
+
+ -- Anything else is an error (illegal switch character)
+
+ when others =>
+ raise Bad_Switch;
+ end case;
+ end loop;
+
+ exception
+ when Bad_Switch =>
+ Osint.Fail ("invalid switch: ", (1 => C));
+
+ when Bad_Switch_Value =>
+ Osint.Fail ("numeric value too big for switch: ", (1 => C));
+
+ when Missing_Switch_Value =>
+ Osint.Fail ("missing numeric value for switch: ", (1 => C));
+
+ when Too_Many_Output_Files =>
+ Osint.Fail ("duplicate -o switch");
+ end Scan_Binder_Switches;
+
+end Switch.B;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S W I T C H - B --
+-- --
+-- S p e c --
+-- --
+-- $Revision$
+-- --
+-- Copyright (C) 2001 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 2, 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package scans binder switches. Note that the body of Usage must be
+-- coordinated with the switches that are recognized by this package.
+-- The Usage package also acts as the official documentation for the
+-- switches that are recognized. In addition, package Debug documents
+-- the otherwise undocumented debug switches that are also recognized.
+
+package Switch.B is
+
+ procedure Scan_Binder_Switches (Switch_Chars : String);
+ -- Procedures to scan out binder switches stored in the given string.
+ -- The first character is known to be a valid switch character, and there
+ -- are no blanks or other switch terminator characters in the string, so
+ -- the entire string should consist of valid switch characters, except that
+ -- an optional terminating NUL character is allowed. A bad switch causes
+ -- a fatal error exit and control does not return. The call also sets
+ -- Usage_Requested to True if a ? switch is encountered.
+
+end Switch.B;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S W I T C H - C --
+-- --
+-- B o d y --
+-- --
+-- $Revision$
+-- --
+-- Copyright (C) 2001-2002 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 2, 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Debug; use Debug;
+with Lib; use Lib;
+with Osint; use Osint;
+with Opt; use Opt;
+with Types; use Types;
+with Validsw; use Validsw;
+with Stylesw; use Stylesw;
+
+with System.WCh_Con; use System.WCh_Con;
+
+package body Switch.C is
+
+ -----------------------------
+ -- Scan_Front_End_Switches --
+ -----------------------------
+
+ procedure Scan_Front_End_Switches (Switch_Chars : String) is
+ Switch_Starts_With_Gnat : Boolean;
+ -- True if first four switch characters are "gnat"
+
+ First_Switch : Boolean := True;
+ -- False for all but first switch
+
+ Ptr : Integer := Switch_Chars'First;
+ Max : constant Integer := Switch_Chars'Last;
+ C : Character := ' ';
+
+ Store_Switch : Boolean := True;
+ First_Char : Integer := Ptr;
+ Storing : String := Switch_Chars;
+ First_Stored : Positive := Ptr + 1;
+ -- The above need comments ???
+
+ begin
+ -- Skip past the initial character (must be the switch character)
+
+ if Ptr = Max then
+ raise Bad_Switch;
+ else
+ Ptr := Ptr + 1;
+ end if;
+
+ -- Remove "gnat" from the switch, if present
+
+ Switch_Starts_With_Gnat :=
+ Ptr + 3 <= Max and then Switch_Chars (Ptr .. Ptr + 3) = "gnat";
+
+ if Switch_Starts_With_Gnat then
+ Ptr := Ptr + 4;
+ First_Stored := Ptr;
+ end if;
+
+ -- Loop to scan through switches given in switch string
+
+ while Ptr <= Max loop
+ Store_Switch := True;
+ First_Char := Ptr;
+ C := Switch_Chars (Ptr);
+
+ -- Processing for a switch
+
+ case Switch_Starts_With_Gnat is
+
+ when False =>
+ -- There are only two front-end switches that
+ -- do not start with -gnat, namely -I and --RTS
+
+ if Switch_Chars (Ptr) = 'I' then
+ Store_Switch := False;
+
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ raise Bad_Switch;
+ end if;
+
+ -- Find out whether this is a -I- or regular -Ixxx switch
+
+ if Ptr = Max and then Switch_Chars (Ptr) = '-' then
+ Look_In_Primary_Dir := False;
+
+ else
+ Add_Src_Search_Dir (Switch_Chars (Ptr .. Max));
+ end if;
+
+ Ptr := Max + 1;
+
+ -- Processing of the --RTS switch. --RTS has been modified by
+ -- gcc and is now of the form -fRTS
+ elsif Ptr + 3 <= Max and then
+ Switch_Chars (Ptr .. Ptr + 3) = "fRTS"
+ then
+ Ptr := Ptr + 1;
+
+ if Ptr + 4 > Max or else Switch_Chars (Ptr + 3) /= '=' then
+ Osint.Fail ("missing path for --RTS");
+ else
+
+ -- valid --RTS switch
+ Opt.No_Stdinc := True;
+ Opt.RTS_Switch := True;
+
+ declare
+ Src_Path_Name : String_Ptr := Get_RTS_Search_Dir
+ (Switch_Chars (Ptr + 4 .. Max), Include);
+ Lib_Path_Name : String_Ptr := Get_RTS_Search_Dir
+ (Switch_Chars (Ptr + 4 .. Max), Objects);
+ begin
+ if Src_Path_Name /= null and then
+ Lib_Path_Name /= null
+ then
+ Add_Search_Dirs (Src_Path_Name, Include);
+ Add_Search_Dirs (Lib_Path_Name, Objects);
+ Ptr := Max + 1;
+ elsif Src_Path_Name = null
+ and Lib_Path_Name = null then
+ Osint.Fail ("RTS path not valid: missing " &
+ "adainclude and adalib directories");
+ elsif Src_Path_Name = null then
+ Osint.Fail ("RTS path not valid: missing " &
+ "adainclude directory");
+ elsif Lib_Path_Name = null then
+ Osint.Fail ("RTS path not valid: missing " &
+ "adalib directory");
+ end if;
+ end;
+ end if;
+ else
+ raise Bad_Switch;
+ end if;
+
+ when True =>
+ -- Process -gnat* options
+
+ case C is
+
+ when 'a' =>
+ Ptr := Ptr + 1;
+ Assertions_Enabled := True;
+
+ -- Processing for A switch
+
+ when 'A' =>
+ Ptr := Ptr + 1;
+ Config_File := False;
+
+ -- Processing for b switch
+
+ when 'b' =>
+ Ptr := Ptr + 1;
+ Brief_Output := True;
+
+ -- Processing for c switch
+
+ when 'c' =>
+ if not First_Switch then
+ Osint.Fail
+ ("-gnatc myust be first if combined with other switches");
+ end if;
+
+ Ptr := Ptr + 1;
+ Operating_Mode := Check_Semantics;
+
+ -- Processing for C switch
+
+ when 'C' =>
+ Ptr := Ptr + 1;
+ Compress_Debug_Names := True;
+
+ -- Processing for d switch
+
+ when 'd' =>
+ Store_Switch := False;
+ Storing (First_Stored) := 'd';
+ -- Note: for the debug switch, the remaining characters in this
+ -- switch field must all be debug flags, since all valid switch
+ -- characters are also valid debug characters.
+
+ -- Loop to scan out debug flags
+
+ while Ptr < Max loop
+ Ptr := Ptr + 1;
+ C := Switch_Chars (Ptr);
+ exit when C = ASCII.NUL or else C = '/' or else C = '-';
+
+ if C in '1' .. '9' or else
+ C in 'a' .. 'z' or else
+ C in 'A' .. 'Z'
+ then
+ Set_Debug_Flag (C);
+ Storing (First_Stored + 1) := C;
+ Store_Compilation_Switch
+ (Storing (Storing'First .. First_Stored + 1));
+
+ else
+ raise Bad_Switch;
+ end if;
+ end loop;
+
+ -- Make sure Zero_Cost_Exceptions is set if gnatdX set. This
+ -- is for backwards compatibility with old versions and usage.
+
+ if Debug_Flag_XX then
+ Zero_Cost_Exceptions_Set := True;
+ Zero_Cost_Exceptions_Val := True;
+ end if;
+
+ return;
+
+ -- Processing for D switch
+
+ when 'D' =>
+ Ptr := Ptr + 1;
+
+ -- Note: -gnatD also sets -gnatx (to turn off cross-reference
+ -- generation in the ali file) since otherwise this generation
+ -- gets confused by the "wrong" Sloc values put in the tree.
+
+ Debug_Generated_Code := True;
+ Xref_Active := False;
+ Set_Debug_Flag ('g');
+
+ -- Processing for e switch
+
+ when 'e' =>
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ raise Bad_Switch;
+ end if;
+
+ case Switch_Chars (Ptr) is
+
+ -- Configuration pragmas
+
+ when 'c' =>
+ Store_Switch := False;
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ raise Bad_Switch;
+ end if;
+
+ Config_File_Name :=
+ new String'(Switch_Chars (Ptr .. Max));
+
+ return;
+
+ -- Mapping file
+
+ when 'm' =>
+ Store_Switch := False;
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ raise Bad_Switch;
+ end if;
+
+ Mapping_File_Name :=
+ new String'(Switch_Chars (Ptr .. Max));
+ return;
+
+ when others =>
+ raise Bad_Switch;
+ end case;
+
+ -- Processing for E switch
+
+ when 'E' =>
+ Ptr := Ptr + 1;
+ Dynamic_Elaboration_Checks := True;
+
+ -- Processing for f switch
+
+ when 'f' =>
+ Ptr := Ptr + 1;
+ All_Errors_Mode := True;
+
+ -- Processing for F switch
+
+ when 'F' =>
+ Ptr := Ptr + 1;
+ External_Name_Exp_Casing := Uppercase;
+ External_Name_Imp_Casing := Uppercase;
+
+ -- Processing for g switch
+
+ when 'g' =>
+ Ptr := Ptr + 1;
+ GNAT_Mode := True;
+ Identifier_Character_Set := 'n';
+ Warning_Mode := Treat_As_Error;
+ Check_Unreferenced := True;
+ Check_Withs := True;
+
+ Set_Default_Style_Check_Options;
+
+ -- Processing for G switch
+
+ when 'G' =>
+ Ptr := Ptr + 1;
+ Print_Generated_Code := True;
+
+ -- Processing for h switch
+
+ when 'h' =>
+ Ptr := Ptr + 1;
+ Usage_Requested := True;
+
+ -- Processing for H switch
+
+ when 'H' =>
+ Ptr := Ptr + 1;
+ HLO_Active := True;
+
+ -- Processing for i switch
+
+ when 'i' =>
+ if Ptr = Max then
+ raise Bad_Switch;
+ end if;
+
+ Ptr := Ptr + 1;
+ C := Switch_Chars (Ptr);
+
+ if C in '1' .. '5'
+ or else C = '8'
+ or else C = '9'
+ or else C = 'p'
+ or else C = 'f'
+ or else C = 'n'
+ or else C = 'w'
+ then
+ Identifier_Character_Set := C;
+ Ptr := Ptr + 1;
+
+ else
+ raise Bad_Switch;
+ end if;
+
+ -- Processing for k switch
+
+ when 'k' =>
+ Ptr := Ptr + 1;
+ Scan_Pos (Switch_Chars, Max, Ptr, Maximum_File_Name_Length);
+
+ -- Processing for l switch
+
+ when 'l' =>
+ Ptr := Ptr + 1;
+ Full_List := True;
+
+ -- Processing for L switch
+
+ when 'L' =>
+ Ptr := Ptr + 1;
+ Zero_Cost_Exceptions_Set := True;
+ Zero_Cost_Exceptions_Val := False;
+
+ -- Processing for m switch
+
+ when 'm' =>
+ Ptr := Ptr + 1;
+ Scan_Pos (Switch_Chars, Max, Ptr, Maximum_Errors);
+
+ -- Processing for n switch
+
+ when 'n' =>
+ Ptr := Ptr + 1;
+ Inline_Active := True;
+
+ -- Processing for N switch
+
+ when 'N' =>
+ Ptr := Ptr + 1;
+ Inline_Active := True;
+ Front_End_Inlining := True;
+
+ -- Processing for o switch
+
+ when 'o' =>
+ Ptr := Ptr + 1;
+ Suppress_Options.Overflow_Checks := False;
+ Opt.Enable_Overflow_Checks := True;
+
+ -- Processing for O switch
+
+ when 'O' =>
+ Ptr := Ptr + 1;
+ Output_File_Name_Present := True;
+
+ -- Processing for p switch
+
+ when 'p' =>
+ Ptr := Ptr + 1;
+ Suppress_Options.Access_Checks := True;
+ Suppress_Options.Accessibility_Checks := True;
+ Suppress_Options.Discriminant_Checks := True;
+ Suppress_Options.Division_Checks := True;
+ Suppress_Options.Elaboration_Checks := True;
+ Suppress_Options.Index_Checks := True;
+ Suppress_Options.Length_Checks := True;
+ Suppress_Options.Overflow_Checks := True;
+ Suppress_Options.Range_Checks := True;
+ Suppress_Options.Storage_Checks := True;
+ Suppress_Options.Tag_Checks := True;
+
+ Validity_Checks_On := False;
+ Opt.Suppress_Checks := True;
+ Opt.Enable_Overflow_Checks := False;
+
+ -- Processing for P switch
+
+ when 'P' =>
+ Ptr := Ptr + 1;
+ Polling_Required := True;
+
+ -- Processing for q switch
+
+ when 'q' =>
+ Ptr := Ptr + 1;
+ Try_Semantics := True;
+
+ -- Processing for q switch
+
+ when 'Q' =>
+ Ptr := Ptr + 1;
+ Force_ALI_Tree_File := True;
+ Try_Semantics := True;
+
+ -- Processing for R switch
+
+ when 'R' =>
+ Ptr := Ptr + 1;
+ Back_Annotate_Rep_Info := True;
+
+ if Ptr <= Max
+ and then Switch_Chars (Ptr) in '0' .. '9'
+ then
+ C := Switch_Chars (Ptr);
+
+ if C in '4' .. '9' then
+ raise Bad_Switch;
+ else
+ List_Representation_Info :=
+ Character'Pos (C) - Character'Pos ('0');
+ Ptr := Ptr + 1;
+ end if;
+
+ if Ptr <= Max and then Switch_Chars (Ptr) = 's' then
+ Ptr := Ptr + 1;
+
+ if List_Representation_Info /= 0 then
+ List_Representation_Info_To_File := True;
+ end if;
+ end if;
+
+ else
+ List_Representation_Info := 1;
+ end if;
+
+ -- Processing for s switch
+
+ when 's' =>
+ if not First_Switch then
+ Osint.Fail
+ ("-gnats myust be first if combined with other switches");
+ end if;
+
+ Ptr := Ptr + 1;
+ Operating_Mode := Check_Syntax;
+
+ -- Processing for t switch
+
+ when 't' =>
+ Ptr := Ptr + 1;
+ Tree_Output := True;
+ Back_Annotate_Rep_Info := True;
+
+ -- Processing for T switch
+
+ when 'T' =>
+ Ptr := Ptr + 1;
+ Scan_Pos (Switch_Chars, Max, Ptr, Table_Factor);
+
+ -- Processing for u switch
+
+ when 'u' =>
+ Ptr := Ptr + 1;
+ List_Units := True;
+
+ -- Processing for U switch
+
+ when 'U' =>
+ Ptr := Ptr + 1;
+ Unique_Error_Tag := True;
+
+ -- Processing for v switch
+
+ when 'v' =>
+ Ptr := Ptr + 1;
+ Verbose_Mode := True;
+
+ -- Processing for V switch
+
+ when 'V' =>
+ Store_Switch := False;
+ Storing (First_Stored) := 'V';
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ raise Bad_Switch;
+
+ else
+ declare
+ OK : Boolean;
+
+ begin
+ Set_Validity_Check_Options
+ (Switch_Chars (Ptr .. Max), OK, Ptr);
+
+ if not OK then
+ raise Bad_Switch;
+ end if;
+
+ for Index in First_Char + 1 .. Max loop
+ Storing (First_Stored + 1) :=
+ Switch_Chars (Index);
+ Store_Compilation_Switch
+ (Storing (Storing'First .. First_Stored + 1));
+ end loop;
+ end;
+ end if;
+
+ Ptr := Max + 1;
+
+ -- Processing for w switch
+
+ when 'w' =>
+ Store_Switch := False;
+ Storing (First_Stored) := 'w';
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ raise Bad_Switch;
+ end if;
+
+ while Ptr <= Max loop
+ C := Switch_Chars (Ptr);
+
+ case C is
+
+ when 'a' =>
+ Constant_Condition_Warnings := True;
+ Elab_Warnings := True;
+ Check_Unreferenced := True;
+ Check_Withs := True;
+ Check_Unreferenced_Formals := True;
+ Implementation_Unit_Warnings := True;
+ Ineffective_Inline_Warnings := True;
+ Warn_On_Redundant_Constructs := True;
+
+ when 'A' =>
+ Constant_Condition_Warnings := False;
+ Elab_Warnings := False;
+ Check_Unreferenced := False;
+ Check_Withs := False;
+ Check_Unreferenced_Formals := False;
+ Implementation_Unit_Warnings := False;
+ Warn_On_Biased_Rounding := False;
+ Warn_On_Dereference := False;
+ Warn_On_Hiding := False;
+ Warn_On_Redundant_Constructs := False;
+ Ineffective_Inline_Warnings := False;
+
+ when 'b' =>
+ Warn_On_Biased_Rounding := True;
+
+ when 'B' =>
+ Warn_On_Biased_Rounding := False;
+
+ when 'c' =>
+ Constant_Condition_Warnings := True;
+
+ when 'C' =>
+ Constant_Condition_Warnings := False;
+
+ when 'd' =>
+ Warn_On_Dereference := True;
+
+ when 'D' =>
+ Warn_On_Dereference := False;
+
+ when 'e' =>
+ Warning_Mode := Treat_As_Error;
+
+ when 'f' =>
+ Check_Unreferenced_Formals := True;
+
+ when 'F' =>
+ Check_Unreferenced_Formals := False;
+
+ when 'h' =>
+ Warn_On_Hiding := True;
+
+ when 'H' =>
+ Warn_On_Hiding := False;
+
+ when 'i' =>
+ Implementation_Unit_Warnings := True;
+
+ when 'I' =>
+ Implementation_Unit_Warnings := False;
+
+ when 'l' =>
+ Elab_Warnings := True;
+
+ when 'L' =>
+ Elab_Warnings := False;
+
+ when 'o' =>
+ Address_Clause_Overlay_Warnings := True;
+
+ when 'O' =>
+ Address_Clause_Overlay_Warnings := False;
+
+ when 'p' =>
+ Ineffective_Inline_Warnings := True;
+
+ when 'P' =>
+ Ineffective_Inline_Warnings := False;
+
+ when 'r' =>
+ Warn_On_Redundant_Constructs := True;
+
+ when 'R' =>
+ Warn_On_Redundant_Constructs := False;
+
+ when 's' =>
+ Warning_Mode := Suppress;
+
+ when 'u' =>
+ Check_Unreferenced := True;
+ Check_Withs := True;
+ Check_Unreferenced_Formals := True;
+
+ when 'U' =>
+ Check_Unreferenced := False;
+ Check_Withs := False;
+ Check_Unreferenced_Formals := False;
+
+ -- Allow and ignore 'w' so that the old
+ -- format (e.g. -gnatwuwl) will work.
+
+ when 'w' =>
+ null;
+
+ when others =>
+ raise Bad_Switch;
+ end case;
+
+ if C /= 'w' then
+ Storing (First_Stored + 1) := C;
+ Store_Compilation_Switch
+ (Storing (Storing'First .. First_Stored + 1));
+ end if;
+
+ Ptr := Ptr + 1;
+ end loop;
+
+ return;
+
+ -- Processing for W switch
+
+ when 'W' =>
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ raise Bad_Switch;
+ end if;
+
+ for J in WC_Encoding_Method loop
+ if Switch_Chars (Ptr) = WC_Encoding_Letters (J) then
+ Wide_Character_Encoding_Method := J;
+ exit;
+
+ elsif J = WC_Encoding_Method'Last then
+ raise Bad_Switch;
+ end if;
+ end loop;
+
+ Upper_Half_Encoding :=
+ Wide_Character_Encoding_Method in
+ WC_Upper_Half_Encoding_Method;
+
+ Ptr := Ptr + 1;
+
+ -- Processing for x switch
+
+ when 'x' =>
+ Ptr := Ptr + 1;
+ Xref_Active := False;
+
+ -- Processing for X switch
+
+ when 'X' =>
+ Ptr := Ptr + 1;
+ Extensions_Allowed := True;
+
+ -- Processing for y switch
+
+ when 'y' =>
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ Set_Default_Style_Check_Options;
+
+ else
+ Store_Switch := False;
+ Storing (First_Stored) := 'y';
+
+ declare
+ OK : Boolean;
+ Last_Stored : Integer;
+
+ begin
+ Set_Style_Check_Options
+ (Switch_Chars (Ptr .. Max), OK, Ptr);
+
+ if not OK then
+ raise Bad_Switch;
+ end if;
+
+ Ptr := First_Char + 1;
+
+ while Ptr <= Max loop
+ Last_Stored := First_Stored + 1;
+ Storing (Last_Stored) := Switch_Chars (Ptr);
+
+ if Switch_Chars (Ptr) = 'M' then
+ loop
+ Ptr := Ptr + 1;
+ exit when Ptr > Max
+ or else Switch_Chars (Ptr) not in '0' .. '9';
+ Last_Stored := Last_Stored + 1;
+ Storing (Last_Stored) := Switch_Chars (Ptr);
+ end loop;
+
+ else
+ Ptr := Ptr + 1;
+ end if;
+
+ Store_Compilation_Switch
+ (Storing (Storing'First .. Last_Stored));
+ end loop;
+ end;
+ end if;
+
+ -- Processing for z switch
+
+ when 'z' =>
+ Ptr := Ptr + 1;
+
+ -- Allowed for compiler, only if this is the only
+ -- -z switch, we do not allow multiple occurrences
+
+ if Distribution_Stub_Mode = No_Stubs then
+ case Switch_Chars (Ptr) is
+ when 'r' =>
+ Distribution_Stub_Mode := Generate_Receiver_Stub_Body;
+
+ when 'c' =>
+ Distribution_Stub_Mode := Generate_Caller_Stub_Body;
+
+ when others =>
+ raise Bad_Switch;
+ end case;
+
+ Ptr := Ptr + 1;
+
+ end if;
+
+ -- Processing for Z switch
+
+ when 'Z' =>
+ Ptr := Ptr + 1;
+ Zero_Cost_Exceptions_Set := True;
+ Zero_Cost_Exceptions_Val := True;
+
+ -- Processing for 83 switch
+
+ when '8' =>
+
+ if Ptr = Max then
+ raise Bad_Switch;
+ end if;
+
+ Ptr := Ptr + 1;
+
+ if Switch_Chars (Ptr) /= '3' then
+ raise Bad_Switch;
+ else
+ Ptr := Ptr + 1;
+ Ada_95 := False;
+ Ada_83 := True;
+ end if;
+
+ -- Ignore extra switch character
+
+ when '/' | '-' =>
+ Ptr := Ptr + 1;
+
+ -- Anything else is an error (illegal switch character)
+
+ when others =>
+ raise Bad_Switch;
+ end case;
+ end case;
+
+ if Store_Switch then
+ Storing (First_Stored .. First_Stored + Ptr - First_Char - 1) :=
+ Switch_Chars (First_Char .. Ptr - 1);
+ Store_Compilation_Switch
+ (Storing (Storing'First .. First_Stored + Ptr - First_Char - 1));
+ end if;
+
+ First_Switch := False;
+ end loop;
+
+ exception
+ when Bad_Switch =>
+ Osint.Fail ("invalid switch: ", (1 => C));
+
+ when Bad_Switch_Value =>
+ Osint.Fail ("numeric value too big for switch: ", (1 => C));
+
+ when Missing_Switch_Value =>
+ Osint.Fail ("missing numeric value for switch: ", (1 => C));
+
+ end Scan_Front_End_Switches;
+
+end Switch.C;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S W I T C H - C --
+-- --
+-- S p e c --
+-- --
+-- $Revision$
+-- --
+-- Copyright (C) 2001 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 2, 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package scans front end switches. Note that the body of Usage must be
+-- coordinated with the switches that are recognized by this package.
+-- The Usage package also acts as the official documentation for the
+-- switches that are recognized. In addition, package Debug documents
+-- the otherwise undocumented debug switches that are also recognized.
+
+package Switch.C is
+
+ procedure Scan_Front_End_Switches (Switch_Chars : String);
+ -- Procedures to scan out front end switches stored in the given string.
+ -- The first character is known to be a valid switch character, and there
+ -- are no blanks or other switch terminator characters in the string, so
+ -- the entire string should consist of valid switch characters, except that
+ -- an optional terminating NUL character is allowed. A bad switch causes
+ -- a fatal error exit and control does not return. The call also sets
+ -- Usage_Requested to True if a ? switch is encountered.
+
+end Switch.C;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S W I T C H - M --
+-- --
+-- B o d y --
+-- --
+-- $Revision$
+-- --
+-- Copyright (C) 2001-2002 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 2, 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Debug; use Debug;
+with Osint; use Osint;
+with Opt; use Opt;
+with Table;
+
+package body Switch.M is
+
+ package Normalized_Switches is new Table.Table
+ (Table_Component_Type => String_Access,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Switch.C.Normalized_Switches");
+ -- This table is used to keep the normalized switches, so that they may be
+ -- reused for subsequent invocations of Normalize_Compiler_Switches with
+ -- similar switches.
+
+ Initial_Number_Of_Switches : constant := 10;
+
+ Global_Switches : Argument_List_Access := null;
+ -- Used by function Normalize_Compiler_Switches
+
+ ---------------------------------
+ -- Normalize_Compiler_Switches --
+ ---------------------------------
+
+ procedure Normalize_Compiler_Switches
+ (Switch_Chars : String;
+ Switches : in out Argument_List_Access;
+ Last : out Natural)
+ is
+ Switch_Starts_With_Gnat : Boolean;
+
+ Ptr : Integer := Switch_Chars'First;
+ Max : constant Integer := Switch_Chars'Last;
+ C : Character := ' ';
+
+ First_Char : Integer := Ptr;
+ Storing : String := Switch_Chars;
+ First_Stored : Positive := Ptr + 1;
+ Last_Stored : Positive := First_Stored;
+
+ procedure Add_Switch_Component (S : String);
+ -- Add a new String_Access component in Switches. If a string equal
+ -- to S is already stored in the table Normalized_Switches, use it.
+ -- Other wise add a new component to the table.
+
+ --------------------------
+ -- Add_Switch_Component --
+ --------------------------
+
+ procedure Add_Switch_Component (S : String) is
+ begin
+ -- If Switches is null, allocate a new array
+
+ if Switches = null then
+ Switches := new Argument_List (1 .. Initial_Number_Of_Switches);
+
+ -- otherwise, if Switches is full, extend it
+
+ elsif Last = Switches'Last then
+ declare
+ New_Switches : Argument_List_Access := new Argument_List
+ (1 .. Switches'Length + Switches'Length);
+ begin
+ New_Switches (1 .. Switches'Length) := Switches.all;
+ Last := Switches'Length;
+ Switches := New_Switches;
+ end;
+ end if;
+
+ -- If this is the first switch, Last designates the first component
+ if Last = 0 then
+ Last := Switches'First;
+
+ else
+ Last := Last + 1;
+ end if;
+
+ -- Look into the table Normalized_Switches for a similar string.
+ -- If one is found, put it at the added component, and return.
+
+ for Index in 1 .. Normalized_Switches.Last loop
+ if S = Normalized_Switches.Table (Index).all then
+ Switches (Last) := Normalized_Switches.Table (Index);
+ return;
+ end if;
+ end loop;
+
+ -- No string equal to S was found in the table Normalized_Switches.
+ -- Add a new component in the table.
+
+ Switches (Last) := new String'(S);
+ Normalized_Switches.Increment_Last;
+ Normalized_Switches.Table (Normalized_Switches.Last) :=
+ Switches (Last);
+ end Add_Switch_Component;
+
+ -- Start of processing for Normalize_Compiler_Switches
+
+ begin
+ Last := 0;
+
+ if Ptr = Max or else Switch_Chars (Ptr) /= '-' then
+ return;
+ end if;
+
+ Ptr := Ptr + 1;
+
+ Switch_Starts_With_Gnat :=
+ Ptr + 3 <= Max and then Switch_Chars (Ptr .. Ptr + 3) = "gnat";
+
+ if Switch_Starts_With_Gnat then
+ Ptr := Ptr + 4;
+ First_Stored := Ptr;
+ end if;
+
+ while Ptr <= Max loop
+ First_Char := Ptr;
+ C := Switch_Chars (Ptr);
+
+ -- Processing for a switch
+
+ case Switch_Starts_With_Gnat is
+
+ when False =>
+ -- All switches that don't start with -gnat stay as is
+
+ Add_Switch_Component (Switch_Chars);
+ return;
+
+ when True =>
+
+ case C is
+
+ -- One-letter switches
+
+ when 'a' | 'A' | 'b' | 'c' | 'C' | 'D' | 'E' | 'f' |
+ 'F' | 'g' | 'h' | 'H' | 'k' | 'l' | 'L' | 'n' | 'N' |
+ 'o' | 'O' | 'p' | 'P' | 'q' | 'Q' | 'r' | 's' | 't' |
+ 'u' | 'U' | 'v' | 'x' | 'X' | 'Z' =>
+ Storing (First_Stored) := C;
+ Add_Switch_Component
+ (Storing (Storing'First .. First_Stored));
+ Ptr := Ptr + 1;
+
+ -- One-letter switches followed by a positive number
+
+ when 'm' | 'T' =>
+ Storing (First_Stored) := C;
+ Last_Stored := First_Stored;
+
+ loop
+ Ptr := Ptr + 1;
+ exit when Ptr > Max
+ or else Switch_Chars (Ptr) not in '0' .. '9';
+ Last_Stored := Last_Stored + 1;
+ Storing (Last_Stored) := Switch_Chars (Ptr);
+ end loop;
+
+ Add_Switch_Component
+ (Storing (Storing'First .. Last_Stored));
+
+ when 'd' =>
+ Storing (First_Stored) := 'd';
+
+ while Ptr < Max loop
+ Ptr := Ptr + 1;
+ C := Switch_Chars (Ptr);
+ exit when C = ASCII.NUL or else C = '/'
+ or else C = '-';
+
+ if C in '1' .. '9' or else
+ C in 'a' .. 'z' or else
+ C in 'A' .. 'Z'
+ then
+ Storing (First_Stored + 1) := C;
+ Add_Switch_Component
+ (Storing (Storing'First .. First_Stored + 1));
+
+ else
+ Last := 0;
+ return;
+ end if;
+ end loop;
+
+ return;
+
+ when 'e' =>
+ -- None of the -gnate switches (-gnatec and -gnatem)
+ -- need to be store in an ALI file.
+
+ return;
+
+ when 'i' =>
+ Storing (First_Stored) := 'i';
+
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ Last := 0;
+ return;
+ end if;
+
+ C := Switch_Chars (Ptr);
+
+ if C in '1' .. '5'
+ or else C = '8'
+ or else C = 'p'
+ or else C = 'f'
+ or else C = 'n'
+ or else C = 'w'
+ then
+ Storing (First_Stored + 1) := C;
+ Add_Switch_Component
+ (Storing (Storing'First .. First_Stored + 1));
+ Ptr := Ptr + 1;
+
+ else
+ Last := 0;
+ return;
+ end if;
+
+ -- -gnatR may be followed by '0', '1', '2' or '3',
+ -- then by 's'
+
+ when 'R' =>
+ Last_Stored := First_Stored;
+ Storing (Last_Stored) := 'R';
+ Ptr := Ptr + 1;
+
+ if Ptr <= Max
+ and then Switch_Chars (Ptr) in '0' .. '9'
+ then
+ C := Switch_Chars (Ptr);
+
+ if C in '4' .. '9' then
+ Last := 0;
+ return;
+
+ else
+ Last_Stored := Last_Stored + 1;
+ Storing (Last_Stored) := C;
+ Ptr := Ptr + 1;
+
+ if Ptr <= Max
+ and then Switch_Chars (Ptr) = 's' then
+ Last_Stored := Last_Stored + 1;
+ Storing (Last_Stored) := 's';
+ Ptr := Ptr + 1;
+ end if;
+ end if;
+ end if;
+
+ Add_Switch_Component
+ (Storing (Storing'First .. Last_Stored));
+
+ -- Multiple switches
+
+ when 'V' | 'w' | 'y' =>
+ Storing (First_Stored) := C;
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ if C = 'y' then
+ Add_Switch_Component
+ (Storing (Storing'First .. First_Stored));
+
+ else
+ Last := 0;
+ return;
+ end if;
+ end if;
+
+ while Ptr <= Max loop
+ C := Switch_Chars (Ptr);
+ Ptr := Ptr + 1;
+
+ -- 'w' should be skipped in -gnatw
+
+ if C /= 'w' or else Storing (First_Stored) /= 'w' then
+
+ -- -gnatyMxxx
+
+ if C = 'M'
+ and then Storing (First_Stored) = 'y' then
+ Last_Stored := First_Stored + 1;
+ Storing (Last_Stored) := 'M';
+
+ while Ptr <= Max loop
+ C := Switch_Chars (Ptr);
+ exit when C not in '0' .. '9';
+ Last_Stored := Last_Stored + 1;
+ Storing (Last_Stored) := C;
+ Ptr := Ptr + 1;
+ end loop;
+
+ -- If there is no digit after -gnatyM,
+ -- the switch is invalid.
+
+ if Last_Stored = First_Stored + 1 then
+ Last := 0;
+ return;
+
+ else
+ Add_Switch_Component
+ (Storing (Storing'First .. Last_Stored));
+ end if;
+
+ -- All other switches are -gnatxx
+
+ else
+ Storing (First_Stored + 1) := C;
+ Add_Switch_Component
+ (Storing (Storing'First .. First_Stored + 1));
+ end if;
+ end if;
+ end loop;
+
+ -- Not a valid switch
+
+ when others =>
+ Last := 0;
+ return;
+
+ end case;
+
+ end case;
+ end loop;
+ end Normalize_Compiler_Switches;
+
+ function Normalize_Compiler_Switches
+ (Switch_Chars : String)
+ return Argument_List
+ is
+ Last : Natural;
+
+ begin
+ Normalize_Compiler_Switches (Switch_Chars, Global_Switches, Last);
+
+ if Last = 0 then
+ return (1 .. 0 => null);
+
+ else
+ return Global_Switches (Global_Switches'First .. Last);
+ end if;
+
+ end Normalize_Compiler_Switches;
+
+ ------------------------
+ -- Scan_Make_Switches --
+ ------------------------
+
+ procedure Scan_Make_Switches (Switch_Chars : String) is
+ Ptr : Integer := Switch_Chars'First;
+ Max : Integer := Switch_Chars'Last;
+ C : Character := ' ';
+
+ begin
+ -- Skip past the initial character (must be the switch character)
+
+ if Ptr = Max then
+ raise Bad_Switch;
+
+ else
+ Ptr := Ptr + 1;
+ end if;
+
+ -- A little check, "gnat" at the start of a switch is not allowed
+ -- except for the compiler (where it was already removed)
+
+ if Switch_Chars'Length >= Ptr + 3
+ and then Switch_Chars (Ptr .. Ptr + 3) = "gnat"
+ then
+ Osint.Fail
+ ("invalid switch: """, Switch_Chars, """ (gnat not needed here)");
+ end if;
+
+ -- Loop to scan through switches given in switch string
+
+ while Ptr <= Max loop
+ C := Switch_Chars (Ptr);
+
+ -- Processing for a switch
+
+ case C is
+
+ when 'a' =>
+ Ptr := Ptr + 1;
+ Check_Readonly_Files := True;
+
+ -- Processing for b switch
+
+ when 'b' =>
+ Ptr := Ptr + 1;
+ Bind_Only := True;
+
+ -- Processing for c switch
+
+ when 'c' =>
+ Ptr := Ptr + 1;
+ Compile_Only := True;
+
+ -- Processing for C switch
+
+ when 'C' =>
+ Ptr := Ptr + 1;
+ Create_Mapping_File := True;
+
+ -- Processing for d switch
+
+ when 'd' =>
+
+ -- Note: for the debug switch, the remaining characters in this
+ -- switch field must all be debug flags, since all valid switch
+ -- characters are also valid debug characters. This switch is not
+ -- documented on purpose because it is only used by the
+ -- implementors.
+
+ -- Loop to scan out debug flags
+
+ while Ptr < Max loop
+ Ptr := Ptr + 1;
+ C := Switch_Chars (Ptr);
+ exit when C = ASCII.NUL or else C = '/' or else C = '-';
+
+ if C in '1' .. '9' or else
+ C in 'a' .. 'z' or else
+ C in 'A' .. 'Z'
+ then
+ Set_Debug_Flag (C);
+ else
+ raise Bad_Switch;
+ end if;
+ end loop;
+
+ -- Make sure Zero_Cost_Exceptions is set if gnatdX set. This
+ -- is for backwards compatibility with old versions and usage.
+
+ if Debug_Flag_XX then
+ Zero_Cost_Exceptions_Set := True;
+ Zero_Cost_Exceptions_Val := True;
+ end if;
+
+ return;
+
+ -- Processing for f switch
+
+ when 'f' =>
+ Ptr := Ptr + 1;
+ Force_Compilations := True;
+
+ -- Processing for h switch
+
+ when 'h' =>
+ Ptr := Ptr + 1;
+ Usage_Requested := True;
+
+ -- Processing for i switch
+
+ when 'i' =>
+ Ptr := Ptr + 1;
+ In_Place_Mode := True;
+
+ -- Processing for j switch
+
+ when 'j' =>
+ Ptr := Ptr + 1;
+
+ declare
+ Max_Proc : Pos;
+ begin
+ Scan_Pos (Switch_Chars, Max, Ptr, Max_Proc);
+ Maximum_Processes := Positive (Max_Proc);
+ end;
+
+ -- Processing for k switch
+
+ when 'k' =>
+ Ptr := Ptr + 1;
+ Keep_Going := True;
+
+ -- Processing for l switch
+
+ when 'l' =>
+ Ptr := Ptr + 1;
+ Link_Only := True;
+
+ when 'M' =>
+ Ptr := Ptr + 1;
+ List_Dependencies := True;
+
+ -- Processing for n switch
+
+ when 'n' =>
+ Ptr := Ptr + 1;
+ Do_Not_Execute := True;
+
+ -- Processing for o switch
+
+ when 'o' =>
+ Ptr := Ptr + 1;
+
+ if Output_File_Name_Present then
+ raise Too_Many_Output_Files;
+ else
+ Output_File_Name_Present := True;
+ end if;
+
+ -- Processing for q switch
+
+ when 'q' =>
+ Ptr := Ptr + 1;
+ Quiet_Output := True;
+
+ -- Processing for s switch
+
+ when 's' =>
+ Ptr := Ptr + 1;
+ Check_Switches := True;
+
+ -- Processing for v switch
+
+ when 'v' =>
+ Ptr := Ptr + 1;
+ Verbose_Mode := True;
+
+ -- Processing for z switch
+
+ when 'z' =>
+ Ptr := Ptr + 1;
+ No_Main_Subprogram := True;
+
+ -- Ignore extra switch character
+
+ when '/' | '-' =>
+ Ptr := Ptr + 1;
+
+ -- Anything else is an error (illegal switch character)
+
+ when others =>
+ raise Bad_Switch;
+
+ end case;
+ end loop;
+
+ exception
+ when Bad_Switch =>
+ Osint.Fail ("invalid switch: ", (1 => C));
+
+ when Bad_Switch_Value =>
+ Osint.Fail ("numeric value too big for switch: ", (1 => C));
+
+ when Missing_Switch_Value =>
+ Osint.Fail ("missing numeric value for switch: ", (1 => C));
+
+ when Too_Many_Output_Files =>
+ Osint.Fail ("duplicate -o switch");
+
+ end Scan_Make_Switches;
+
+end Switch.M;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S W I T C H - M --
+-- --
+-- S p e c --
+-- --
+-- $Revision$
+-- --
+-- Copyright (C) 2001 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 2, 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package scans make switches. Note that the body of Usage must be
+-- coordinated with the switches that are recognized by this package.
+-- The Usage package also acts as the official documentation for the
+-- switches that are recognized. In addition, package Debug documents
+-- the otherwise undocumented debug switches that are also recognized.
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+package Switch.M is
+
+ procedure Scan_Make_Switches (Switch_Chars : String);
+ -- Procedures to scan out binder switches stored in the given string.
+ -- The first character is known to be a valid switch character, and there
+ -- are no blanks or other switch terminator characters in the string, so
+ -- the entire string should consist of valid switch characters, except that
+ -- an optional terminating NUL character is allowed. A bad switch causes
+ -- a fatal error exit and control does not return. The call also sets
+ -- Usage_Requested to True if a ? switch is encountered.
+
+ procedure Normalize_Compiler_Switches
+ (Switch_Chars : String;
+ Switches : in out Argument_List_Access;
+ Last : out Natural);
+ -- Takes a compiler switch which potentially is equivalent to more
+ -- that one simple switches and returns the equivalent list of simple
+ -- switches that are stored in an ALI file. Switches will be extended
+ -- if initially null or too short. Last indicates the index in Switches
+ -- of the last simple switch. Last is equal to zero, if it has been
+ -- determined that Switch_Chars is ill-formed or does not contain any
+ -- switch that should be stored in an ALI file. Otherwise, the list of
+ -- simple switches is Switches (Switches'First .. Last).
+ --
+ -- Example: if Switch_Chars is equal to "-gnatAwue", then the list of
+ -- simple switches will have 3 components: -gnatA, -gnatwu, -gnatwe.
+ --
+ -- The String_Access components of Switches should not be deallocated:
+ -- they are shallow copies of components in a table in the body.
+
+ function Normalize_Compiler_Switches
+ (Switch_Chars : String)
+ return Argument_List;
+ -- Similar to the previous procedure. The return value is the list of
+ -- simple switches. It may be an empty array if it has been determined
+ -- that Switch_Chars is ill-formed or does not contain any switch that
+ -- should be stored in an ALI file. The String_Access components of the
+ -- returned value should not be deallocated.
+
+end Switch.M;
projects / platform / upstream / gcc.git / commitdiff