diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/ada/adadecode.c | 325 | ||||
| -rw-r--r-- | gcc/ada/adadecode.h | 52 | ||||
| -rw-r--r-- | gcc/ada/aux-io.c | 102 | ||||
| -rw-r--r-- | gcc/ada/s-traces.adb | 58 | ||||
| -rw-r--r-- | gcc/ada/s-traces.ads | 117 | ||||
| -rw-r--r-- | gcc/ada/s-tratas.adb | 123 | ||||
| -rw-r--r-- | gcc/ada/s-tratas.ads | 98 | ||||
| -rw-r--r-- | gcc/ada/sinput-d.adb | 113 | ||||
| -rw-r--r-- | gcc/ada/sinput-d.ads | 63 | ||||
| -rw-r--r-- | gcc/ada/switch-b.adb | 428 | ||||
| -rw-r--r-- | gcc/ada/switch-b.ads | 46 | ||||
| -rw-r--r-- | gcc/ada/switch-c.adb | 870 | ||||
| -rw-r--r-- | gcc/ada/switch-c.ads | 46 | ||||
| -rw-r--r-- | gcc/ada/switch-m.adb | 591 | ||||
| -rw-r--r-- | gcc/ada/switch-m.ads | 76 |
16 files changed, 3115 insertions, 0 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3791b448461..1e7825ad3a0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,12 @@ 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, diff --git a/gcc/ada/adadecode.c b/gcc/ada/adadecode.c new file mode 100644 index 00000000000..cafd1c35b09 --- /dev/null +++ b/gcc/ada/adadecode.c @@ -0,0 +1,325 @@ +/**************************************************************************** + * * + * 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; +} diff --git a/gcc/ada/adadecode.h b/gcc/ada/adadecode.h new file mode 100644 index 00000000000..94ac87190be --- /dev/null +++ b/gcc/ada/adadecode.h @@ -0,0 +1,52 @@ +/**************************************************************************** + * * + * 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 *)); diff --git a/gcc/ada/aux-io.c b/gcc/ada/aux-io.c new file mode 100644 index 00000000000..ef4d647c875 --- /dev/null +++ b/gcc/ada/aux-io.c @@ -0,0 +1,102 @@ +/**************************************************************************** + * * + * 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); +} diff --git a/gcc/ada/s-traces.adb b/gcc/ada/s-traces.adb new file mode 100644 index 00000000000..3fbfa5d3d7a --- /dev/null +++ b/gcc/ada/s-traces.adb @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-traces.ads b/gcc/ada/s-traces.ads new file mode 100644 index 00000000000..aa723675619 --- /dev/null +++ b/gcc/ada/s-traces.ads @@ -0,0 +1,117 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-tratas.adb b/gcc/ada/s-tratas.adb new file mode 100644 index 00000000000..59124eadbff --- /dev/null +++ b/gcc/ada/s-tratas.adb @@ -0,0 +1,123 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-tratas.ads b/gcc/ada/s-tratas.ads new file mode 100644 index 00000000000..4713932b1db --- /dev/null +++ b/gcc/ada/s-tratas.ads @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/sinput-d.adb b/gcc/ada/sinput-d.adb new file mode 100644 index 00000000000..6666a0ffa75 --- /dev/null +++ b/gcc/ada/sinput-d.adb @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/sinput-d.ads b/gcc/ada/sinput-d.ads new file mode 100644 index 00000000000..015b92affa9 --- /dev/null +++ b/gcc/ada/sinput-d.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb new file mode 100644 index 00000000000..c442e6aeaae --- /dev/null +++ b/gcc/ada/switch-b.adb @@ -0,0 +1,428 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/switch-b.ads b/gcc/ada/switch-b.ads new file mode 100644 index 00000000000..e58c1329da7 --- /dev/null +++ b/gcc/ada/switch-b.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb new file mode 100644 index 00000000000..7f34b1bdd37 --- /dev/null +++ b/gcc/ada/switch-c.adb @@ -0,0 +1,870 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/switch-c.ads b/gcc/ada/switch-c.ads new file mode 100644 index 00000000000..eec6f11eab5 --- /dev/null +++ b/gcc/ada/switch-c.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb new file mode 100644 index 00000000000..ec08a6d8c31 --- /dev/null +++ b/gcc/ada/switch-m.adb @@ -0,0 +1,591 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/switch-m.ads b/gcc/ada/switch-m.ads new file mode 100644 index 00000000000..f142fa40cdb --- /dev/null +++ b/gcc/ada/switch-m.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; |