OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR ada/12014 (strcpy used with overlapping arguments) 

* adadecode.c (ostrcpy): New function.
	(__gnat_decode): Use ostrcpy of strcpy.
	(has_prefix): Set first parameter a const.
	(has_suffix): Set first parameter a const.
	Update copyright notice. Fix source name in header.
	Removes a trailing space.
	PR ada/12014.

	* exp_disp.adb:
	Remove the test against being in No_Run_Time_Mode before generating a
	call to Register_Tag. It is redundant with the test against the
	availability of the function Register_Tag.

	* g-catiio.adb: (Month_Name): Correct spelling of February

	* make.adb: (Mains): New package
	(Initialize): Call Mains.Delete
	(Gnatmake): Check that each main on the command line is a source of a
	project file and, if there are several mains, each of them is a source
	of the same project file.
	(Gnatmake): When a foreign language is specified in attribute Languages,
	no main is specified on the command line and attribute Mains is not
	empty, only build the Ada main. If there is no Ada main, just compile
	the Ada sources and their closure.
	(Gnatmake): If a main is specified on the command line with directory
	information, check that the source exists and, if it does, that the path
	is the actual path of a source of a project.

	* prj-env.adb:
	(File_Name_Of_Library_Unit_Body): New Boolean parameter Full_Path. When
	Full_Path is True, return the full path instead of the simple file name.
	(Project_Of): New function

	* prj-env.ads:
	(File_Name_Of_Library_Unit_Body): New Boolean parameter Full_Path,
	defaulted to False.
	(Project_Of): New function

	* Makefile.generic:
	Ensure objects of main project are always checked and rebuilt if needed.
	Set CC to gcc by default.
	Prepare new handling of link by creating a global archive (not activated
	yet).

	* adadecode.h, atree.h, elists.h, nlists.h, raise.h,
	stringt.h: Update copyright notice. Remove trailing blanks.
	Fix source name in header.

	* sem_ch12.adb: Minor reformatting

	* sem_ch3.adb:
	Minor reformatting (including new function return style throughout)

	* sem_ch3.ads:
	Minor reformatting (including new function return style throughout)

	* Make-lang.in: Makefile automatically updated

From-SVN: r72893
This commit is contained in:
Arnaud Charlet 2003-10-24 15:02:42 +02:00
parent bf22935f99
commit b0f26df5db
16 changed files with 1384 additions and 1320 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2007
gcc/ada/Make-lang.in
View File

File diff suppressed because it is too large Load Diff

57
gcc/ada/Makefile.generic
View File

@ -47,6 +47,7 @@
# CXX name of the C++ compiler (optional, default to gcc)
# AR_CMD command to create an archive (optional, default to "ar rc")
# AR_EXT file extension of an archive (optional, default to ".a")
# RANLIB command to generate an index (optional, default to "ranlib")
# GNATMAKE name of the GNAT builder (optional, default to "gnatmake")
# ADAFLAGS additional Ada compilation switches, e.g "-gnatf" (optional)
# CFLAGS default C compilation switches, e.g "-O2 -g" (optional)
@ -56,6 +57,7 @@
# ADA_SOURCES list of main Ada sources (optional)
# EXEC name of the final executable (optional)
# MAIN language of the main program (optional)
# MAIN_OBJECT main object file (optional)
# PROJECT_FILE name of the project file, without the .gpr extension
# DEPS_PROJECTS list of project dependencies (optional)
@ -65,6 +67,10 @@ ifndef MAIN
MAIN=ada
endif
ifndef CC
CC=gcc
endif
ifndef ADA_SPEC
ADA_SPEC=.ads
endif
@ -100,10 +106,18 @@ ifndef AR_CMD
AR_CMD=ar rc
endif
ifndef RANLIB
RANLIB=ranlib
endif
ifndef GNATMAKE
GNATMAKE=gnatmake
endif
ifndef ARCHIVE
ARCHIVE=$(OBJ_DIR)/lib$(PROJECT_BASE)-full$(AR_EXT)
endif
ifeq ($(EXEC_DIR),)
EXEC_DIR=$(OBJ_DIR)
endif
@ -120,6 +134,7 @@ vpath %$(AR_EXT) $(OBJ_DIR)
clean_deps = $(subst :,|,$(DEPS_PROJECTS:%=clean_%))
compile_deps = $(subst :,|,$(DEPS_PROJECTS:%=compile_%))
object_deps = $(subst :,|,$(DEPS_PROJECTS:%=object_%))
ada_deps = $(subst :,|,$(DEPS_PROJECTS:%=ada_%))
c_deps = $(subst :,|,$(DEPS_PROJECTS:%=c_%))
c++_deps = $(subst :,|,$(DEPS_PROJECTS:%=c++_%))
@ -131,6 +146,7 @@ clean: $(clean_deps) internal-clean
build: $(compile_deps) internal-compile internal-build
compile: $(compile_deps) internal-compile $(ADA_SOURCES)
ada: $(ada_deps) internal-ada
archive-objects: $(object_deps) internal-archive-objects
c: $(c_deps) internal-c
c++: $(c++deps) internal-c++
@ -140,6 +156,9 @@ $(clean_deps): force
$(compile_deps): force
@$(MAKE) -C $(dir $(subst |,:,$(@:compile_%=%))) -f Makefile.$(notdir $@) internal-compile
$(object_deps): force
@$(MAKE) -C $(dir $(@:object_%=%)) -f Makefile.$(notdir $@) internal-archive-objects ARCHIVE=$(ARCHIVE)
$(ada_deps): force
@$(MAKE) -C $(dir $(subst |,:,$(@:ada_%=%))) -f Makefile.$(notdir $@) internal-ada
@ -238,6 +257,7 @@ DEP_FILES := $(OBJ_FILES:$(OBJ_EXT)=.d)
ifeq ($(strip $(OBJECTS)),)
internal-compile:
internal-archive-objects:
else
internal-compile: lib$(PROJECT_BASE)$(AR_EXT)
@ -245,7 +265,13 @@ internal-compile: lib$(PROJECT_BASE)$(AR_EXT)
lib$(PROJECT_BASE)$(AR_EXT): $(OBJECTS)
@echo creating archive file for $(PROJECT_BASE)
cd $(OBJ_DIR); $(AR_CMD) $@ $(strip $(OBJECTS))
-ranlib $(OBJ_DIR)/$@
-$(RANLIB) $(OBJ_DIR)/$@
internal-archive-objects: $(OBJECTS)
# @echo $(AR_CMD) $(ARCHIVE) $(strip $(OBJECTS))
# cd $(OBJ_DIR); $(AR_CMD) $(ARCHIVE) $(strip $(OBJECTS))
# -$(RANLIB) $(OBJ_DIR)/$@
endif
# Linking rules
@ -260,9 +286,24 @@ endif
ifeq ($(strip $(filter-out c c++,$(LANGUAGES))),)
# link with C/C++
link: $(EXEC_DIR)/$(EXEC)
ifeq ($(MAIN_OBJECT),)
link:
@echo link: no main object specified, exiting...
exit 1
else
ifeq ($(EXEC),)
link:
@echo link: no executable specified, exiting...
exit 1
else
link: $(EXEC_DIR)/$(EXEC) archive-objects
$(EXEC_DIR)/$(EXEC): $(OBJ_FILES)
$(LINKER) $(OBJ_FILES) -o $(EXEC_DIR)/$(EXEC) $(LDFLAGS)
@echo $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
$(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
endif
endif
internal-build: internal-compile link
@ -272,11 +313,11 @@ ifeq ($(strip $(filter-out c c++ ada,$(LANGUAGES))),)
ifeq ($(MAIN),ada)
# Ada main
link: $(LINKER) force
link: $(LINKER) archive-objects force
$(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(LARGS) $(LDFLAGS)
internal-build: $(LINKER) force
internal-build: $(LINKER) archive-objects force
@echo $(GNATMAKE) -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) -P$(PROJECT_FILE) $(EXEC_RULE) $(ADA_SOURCES) $(ADAFLAGS) \
-largs $(LARGS) $(LDFLAGS)
@ -288,11 +329,11 @@ else
# close enough to our needs, and the usual -n gnatbind switch and --LINK=
# gnatlink switch.
link: $(LINKER) force
link: $(LINKER) archive-objects force
$(GNATMAKE) $(EXEC_RULE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) \
-bargs -n -largs $(LARGS) $(LDFLAGS)
internal-build: $(LINKER) force
internal-build: $(LINKER) archive-objects force
@echo $(GNATMAKE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) $(EXEC_RULE) -z \
-P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
@ -385,7 +426,7 @@ internal-c : $(C_OBJECTS)
# Compile all C++ files in the project
internal-c++ : $(CXX_OBJECTS)
.PHONY: force internal-clean internal-build internal-compile internal-ada internal-c internal-c++ build compile clean ada c c++
.PHONY: force internal-clean internal-archive internal-build internal-compile internal-ada internal-c internal-c++ build compile clean ada c c++
internal-clean:
@echo $(RM) $(OBJ_DIR)/*$(OBJ_EXT)

46
gcc/ada/adadecode.c
View File

@ -2,11 +2,11 @@
* *
* GNAT COMPILER COMPONENTS *
* *
* G N A T D E C O *
* A D A D E C O D E *
* *
* C Implementation File *
* *
* Copyright (C) 2001-2002, Free Software Foundation, Inc. *
* Copyright (C) 2001-2003, 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- *
@ -42,8 +42,12 @@
#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 *));
static int has_prefix PARAMS ((const char *, const char *));
static int has_suffix PARAMS ((const char *, const char *));
/* This is a safe version of strcpy that can be used with overlapped
pointers. Does nothing if s2 <= s1. */
static void ostrcpy (char *s1, char *s2);
/* Set to nonzero if we have written any verbose info. */
static int verbose_info;
@ -65,7 +69,7 @@ static void add_verbose (text, ada_name)
static int
has_prefix (name, prefix)
char *name;
const char *name;
const char *prefix;
{
return strncmp (name, prefix, strlen (prefix)) == 0;
@ -75,7 +79,7 @@ has_prefix (name, prefix)
static int
has_suffix (name, suffix)
char *name;
const char *name;
const char *suffix;
{
int nlen = strlen (name);
@ -84,6 +88,18 @@ has_suffix (name, suffix)
return nlen > slen && strncmp (name + nlen - slen, suffix, slen) == 0;
}
/* Safe overlapped pointers version of strcpy. */
static void
ostrcpy (char *s1, char *s2)
{
if (s2 > s1)
{
while (*s2) *s1++ = *s2++;
*s1 = '\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
@ -142,16 +158,14 @@ __gnat_decode (coded_name, ada_name, verbose)
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_"))
if (has_prefix (coded_name, "_ada_"))
{
strcpy (ada_name, ada_name + 5);
strcpy (ada_name, coded_name + 5);
lib_subprog = 1;
}
else
strcpy (ada_name, coded_name);
/* Check for task body. */
if (has_suffix (ada_name, "TKB"))
@ -191,7 +205,7 @@ __gnat_decode (coded_name, ada_name, verbose)
while ((tktoken = (char *) strstr (ada_name, "TK__")) != NULL)
{
strcpy (tktoken, tktoken + 2);
ostrcpy (tktoken, tktoken + 2);
in_task = 1;
}
}
@ -229,7 +243,7 @@ __gnat_decode (coded_name, ada_name, verbose)
if (ada_name[k] == '_' && ada_name[k+1] == '_')
{
ada_name[k] = '.';
strcpy (ada_name + k + 1, ada_name + k + 2);
ostrcpy (ada_name + k + 1, ada_name + k + 2);
len = len - 1;
}
k++;
@ -259,7 +273,7 @@ __gnat_decode (coded_name, ada_name, verbose)
if (codedlen > oplen)
/* We shrink the space. */
strcpy (optoken, optoken + codedlen - oplen);
ostrcpy (optoken, optoken + codedlen - oplen);
else if (oplen > codedlen)
{
/* We need more space. */
@ -285,7 +299,7 @@ __gnat_decode (coded_name, ada_name, verbose)
}
/* If verbose mode is on, we add some information to the Ada name. */
if (verbose)
if (verbose)
{
if (overloaded)
add_verbose ("overloaded", ada_name);

4
gcc/ada/adadecode.h
View File

@ -2,11 +2,11 @@
* *
* GNAT COMPILER COMPONENTS *
* *
* G N A T D E C O *
* A D A D E C O D E *
* *
* C Header File *
* *
* Copyright (C) 2001-2002, Free Software Foundation, Inc. *
* Copyright (C) 2001-2003, 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- *

4
gcc/ada/atree.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* Copyright (C) 1992-2001, Free Software Foundation, Inc. *
* Copyright (C) 1992-2003, 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- *
@ -235,7 +235,7 @@ struct Extended
Int field8;
Int field9;
Int field10;
union
union
{
Int field11;
struct Flag_Word3 fw3;

2
gcc/ada/elists.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* Copyright (C) 1992-2001 Free Software Foundation, Inc. *
* Copyright (C) 1992-2003 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- *

3
gcc/ada/exp_disp.adb
View File

@ -922,11 +922,10 @@ package body Exp_Disp is
-- Register_Tag (Dt_Ptr);
-- Skip this if routine not available, or in No_Run_Time mode
-- Skip this if routine not available
if RTE_Available (RE_Register_Tag)
and then Is_RTE (Generalized_Tag, RE_Tag)
and then not No_Run_Time_Mode
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,

2
gcc/ada/g-catiio.adb
View File

@ -44,7 +44,7 @@ package body GNAT.Calendar.Time_IO is
type Month_Name is
(January,
Febuary,
February,
March,
April,
May,

323
gcc/ada/make.adb
View File

@ -28,6 +28,7 @@ with Ada.Exceptions; use Ada.Exceptions;
with Ada.Command_Line; use Ada.Command_Line;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Case_Util; use GNAT.Case_Util;
with ALI; use ALI;
with ALI.Util; use ALI.Util;
@ -178,6 +179,31 @@ package body Make is
Table_Name => "Make.Q");
-- This is the actual Q.
-- Package Mains is used to store the mains specified on the command line
-- and to retrieve them when a project file is used, to verify that the
-- files exist and that they belong to a project file.
package Mains is
-- Mains are stored in a table. An index is used to retrieve the mains
-- from the table.
procedure Add_Main (Name : String);
-- Add one main to the table
procedure Delete;
-- Empty the table
procedure Reset;
-- Reset the index to the beginning of the table
function Next_Main return String;
-- Increase the index and return the next main.
-- If table is exhausted, return an empty string.
end Mains;
-- The following instantiations and variables are necessary to save what
-- is found on the command line, in case there is a project file specified.
@ -3340,6 +3366,147 @@ package body Make is
if Projects.Table (Main_Project).Library then
Make_Failed ("cannot specify a main program " &
"on the command line for a library project file");
else
-- Check that each main on the command line is a source of a
-- project file and, if there are several mains, each of them
-- is a source of the same project file.
Mains.Reset;
declare
Real_Main_Project : Project_Id := No_Project;
-- The project of the first main
Proj : Project_Id := No_Project;
-- The project of the current main
begin
-- Check each main
loop
declare
Main : constant String := Mains.Next_Main;
-- The name specified on the command line may include
-- directory information.
File_Name : constant String := Base_Name (Main);
-- The simple file name of the current main main
begin
exit when Main = "";
-- Get the project of the current main
Proj := Prj.Env.Project_Of (File_Name, Main_Project);
-- Fail if the current main is not a source of a
-- project.
if Proj = No_Project then
Make_Failed
("""" & Main &
""" is not a source of any project");
else
-- If there is directory information, check that
-- the source exists and, if it does, that the path
-- is the actual path of a source of a project.
if Main /= File_Name then
declare
Data : constant Project_Data :=
Projects.Table (Main_Project);
Project_Path : constant String :=
Prj.Env.File_Name_Of_Library_Unit_Body
(Name => File_Name,
Project => Main_Project,
Main_Project_Only => False,
Full_Path => True);
Real_Path : String_Access :=
Locate_Regular_File
(Main &
Get_Name_String
(Data.Naming.Current_Body_Suffix),
"");
begin
if Real_Path = null then
Real_Path :=
Locate_Regular_File
(Main &
Get_Name_String
(Data.Naming.Current_Spec_Suffix),
"");
end if;
if Real_Path = null then
Real_Path :=
Locate_Regular_File (Main, "");
end if;
-- Fail if the file cannot be found
if Real_Path = null then
Make_Failed
("file """ & Main & """ does not exist");
end if;
declare
Normed_Path : constant String :=
Normalize_Pathname
(Real_Path.all,
Case_Sensitive => False);
begin
Free (Real_Path);
-- Fail if it is not the correct path
if Normed_Path /= Project_Path then
if Verbose_Mode then
Write_Str (Normed_Path);
Write_Str (" /= ");
Write_Line (Project_Path);
end if;
Make_Failed
("""" & Main &
""" is not a source of any project");
end if;
end;
end;
end if;
if not Unique_Compile then
-- Record the project, if it is the first main
if Real_Main_Project = No_Project then
Real_Main_Project := Proj;
elsif Proj /= Real_Main_Project then
-- Fail, as the current main is not a source
-- of the same project as the first main.
Make_Failed
("""" & Main &
""" is not a source of project " &
Get_Name_String
(Projects.Table
(Real_Main_Project).Name));
end if;
end if;
end if;
-- If -u and -U are not used, we may have mains that
-- are sources of a project that is not the one
-- specified with switch -P.
if not Unique_Compile then
Main_Project := Real_Main_Project;
end if;
end;
end loop;
end;
end if;
-- If no mains have been specified on the command line,
@ -3383,13 +3550,92 @@ package body Make is
else
-- The attribute Main is not an empty list.
-- Put all the main subprograms in the list as if there
-- were specified on the command line.
-- were specified on the command line. However, if attribute
-- Languages includes a language other than Ada, only
-- include the Ada mains; if there is no Ada main, compile
-- all the sources of the project.
while Value /= Prj.Nil_String loop
Get_Name_String (String_Elements.Table (Value).Value);
Osint.Add_File (Name_Buffer (1 .. Name_Len));
Value := String_Elements.Table (Value).Next;
end loop;
declare
Data : Project_Data := Projects.Table (Main_Project);
Languages : Variable_Value :=
Prj.Util.Value_Of
(Name_Languages, Data.Decl.Attributes);
Current : String_List_Id;
Element : String_Element;
Foreign_Language : Boolean := False;
At_Least_One_Main : Boolean := False;
begin
-- First, determine if there is a foreign language in
-- attribute Languages.
if not Languages.Default then
Current := Languages.Values;
Look_For_Foreign :
while Current /= Nil_String loop
Element := String_Elements.Table (Current);
Get_Name_String (Element.Value);
To_Lower (Name_Buffer (1 .. Name_Len));
if Name_Buffer (1 .. Name_Len) /= "ada" then
Foreign_Language := True;
exit Look_For_Foreign;
end if;
Current := Element.Next;
end loop Look_For_Foreign;
end if;
-- The, find all mains, or if there is a foreign
-- language, all the Ada mains.
while Value /= Prj.Nil_String loop
Get_Name_String (String_Elements.Table (Value).Value);
-- To know if a main is an Ada main, get its project;
-- it should be the project specified on the command
-- line.
if (not Foreign_Language) or else
Prj.Env.Project_Of
(Name_Buffer (1 .. Name_Len), Main_Project) =
Main_Project
then
At_Least_One_Main := True;
Osint.Add_File
(Get_Name_String
(String_Elements.Table (Value).Value));
end if;
Value := String_Elements.Table (Value).Next;
end loop;
-- If we did not get any main, it means that all mains
-- in attribute Mains are in a foreign language. So,
-- we put all sources of the main project in the Q.
if not At_Least_One_Main then
-- First make sure that the binder and the linker
-- will not be invoked.
Do_Bind_Step := False;
Do_Link_Step := False;
-- Put all the sources in the queue
Insert_Project_Sources
(The_Project => Main_Project,
All_Projects => Unique_Compile_All_Projects,
Into_Q => False);
-- If there are no sources to compile, we fail
if Osint.Number_Of_Files = 0 then
Make_Failed ("no sources to compile");
end if;
end if;
end;
end if;
end;
@ -5256,6 +5502,8 @@ package body Make is
RTS_Specified := null;
Mains.Delete;
Next_Arg := 1;
Scan_Args : while Next_Arg <= Argument_Count loop
Scan_Make_Arg (Argument (Next_Arg), And_Save => True);
@ -5850,6 +6098,68 @@ package body Make is
Set_Standard_Error;
end List_Depend;
-----------
-- Mains --
-----------
package body Mains is
package Names is new Table.Table
(Table_Component_Type => File_Name_Type,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Make.Mains.Names");
-- The table that stores the main
Current : Natural := 0;
-- The index of the last main retrieved from the table
--------------
-- Add_Main --
--------------
procedure Add_Main (Name : String) is
begin
Name_Len := 0;
Add_Str_To_Name_Buffer (Name);
Names.Increment_Last;
Names.Table (Names.Last) := Name_Find;
end Add_Main;
------------
-- Delete --
------------
procedure Delete is
begin
Names.Set_Last (0);
Reset;
end Delete;
---------------
-- Next_Main --
---------------
function Next_Main return String is
begin
if Current >= Names.Last then
return "";
else
Current := Current + 1;
return Get_Name_String (Names.Table (Current));
end if;
end Next_Main;
procedure Reset is
begin
Current := 0;
end Reset;
end Mains;
----------
-- Mark --
----------
@ -6521,6 +6831,7 @@ package body Make is
else
Add_File (Argv);
Mains.Add_Main (Argv);
end if;
end Scan_Make_Arg;

2
gcc/ada/nlists.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* Copyright (C) 1992-2001, Free Software Foundation, Inc. *
* Copyright (C) 1992-2003, 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- *

131
gcc/ada/prj-env.adb
View File

@ -1060,7 +1060,8 @@ package body Prj.Env is
function File_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id;
Main_Project_Only : Boolean := True)
Main_Project_Only : Boolean := True;
Full_Path : Boolean := False)
return String
is
The_Project : Project_Id := Project;
@ -1151,7 +1152,13 @@ package body Prj.Env is
Write_Line (" OK");
end if;
return Get_Name_String (Current_Name);
if Full_Path then
return Get_Name_String
(Unit.File_Names (Body_Part).Path);
else
return Get_Name_String (Current_Name);
end if;
-- If it has the name of the extended body name,
-- return the extended body name
@ -1161,7 +1168,13 @@ package body Prj.Env is
Write_Line (" OK");
end if;
return Extended_Body_Name;
if Full_Path then
return Get_Name_String
(Unit.File_Names (Body_Part).Path);
else
return Extended_Body_Name;
end if;
else
if Current_Verbosity = High then
@ -1202,7 +1215,14 @@ package body Prj.Env is
Write_Line (" OK");
end if;
return Get_Name_String (Current_Name);
if Full_Path then
return Get_Name_String
(Unit.File_Names (Specification).Path);
else
return Get_Name_String (Current_Name);
end if;
-- If it has the same name as the extended spec name,
-- return the extended spec name.
@ -1212,7 +1232,13 @@ package body Prj.Env is
Write_Line (" OK");
end if;
return Extended_Spec_Name;
if Full_Path then
return Get_Name_String
(Unit.File_Names (Specification).Path);
else
return Extended_Spec_Name;
end if;
else
if Current_Verbosity = High then
@ -1701,6 +1727,101 @@ package body Prj.Env is
Write_Line ("end of List of Sources.");
end Print_Sources;
----------------
-- Project_Of --
----------------
function Project_Of
(Name : String;
Main_Project : Project_Id)
return Project_Id
is
Result : Project_Id := No_Project;
Original_Name : String := Name;
Data : constant Project_Data := Projects.Table (Main_Project);
Extended_Spec_Name : String :=
Name & Namet.Get_Name_String
(Data.Naming.Current_Spec_Suffix);
Extended_Body_Name : String :=
Name & Namet.Get_Name_String
(Data.Naming.Current_Body_Suffix);
Unit : Unit_Data;
Current_Name : Name_Id;
The_Original_Name : Name_Id;
The_Spec_Name : Name_Id;
The_Body_Name : Name_Id;
begin
Canonical_Case_File_Name (Original_Name);
Name_Len := Original_Name'Length;
Name_Buffer (1 .. Name_Len) := Original_Name;
The_Original_Name := Name_Find;
Canonical_Case_File_Name (Extended_Spec_Name);
Name_Len := Extended_Spec_Name'Length;
Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
The_Spec_Name := Name_Find;
Canonical_Case_File_Name (Extended_Body_Name);
Name_Len := Extended_Body_Name'Length;
Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
The_Body_Name := Name_Find;
for Current in reverse Units.First .. Units.Last loop
Unit := Units.Table (Current);
-- Check for body
Current_Name := Unit.File_Names (Body_Part).Name;
-- Case of a body present
if Current_Name /= No_Name then
-- If it has the name of the original name or the body name,
-- we have found the project.
if Unit.Name = The_Original_Name
or else Current_Name = The_Original_Name
or else Current_Name = The_Body_Name
then
Result := Unit.File_Names (Body_Part).Project;
exit;
end if;
end if;
-- Check for spec
Current_Name := Unit.File_Names (Specification).Name;
if Current_Name /= No_Name then
-- If name same as the original name, or the spec name, we have
-- found the project.
if Unit.Name = The_Original_Name
or else Current_Name = The_Original_Name
or else Current_Name = The_Spec_Name
then
Result := Unit.File_Names (Specification).Project;
exit;
end if;
end if;
end loop;
-- Get the ultimate extending project
if Result /= No_Project then
while Projects.Table (Result).Extended_By /= No_Project loop
Result := Projects.Table (Result).Extended_By;
end loop;
end if;
return Result;
end Project_Of;
-------------------
-- Set_Ada_Paths --
-------------------

18
gcc/ada/prj-env.ads
View File

@ -101,17 +101,29 @@ package Prj.Env is
function File_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id;
Main_Project_Only : Boolean := True)
Main_Project_Only : Boolean := True;
Full_Path : Boolean := False)
return String;
-- Returns the file name of a library unit, in canonical case. Name may or
-- may not have an extension (corresponding to the naming scheme of the
-- project). If there is no body with this name, but there is a spec, the
-- name of the spec is returned. If neither a body or a spec can be found,
-- return an empty string.
-- name of the spec is returned.
-- If Full_Path is False (the default), the simple file name is returned.
-- If Full_Path is True, the absolute path name is returned.
-- If neither a body nor a spec can be found, an empty string is returned.
-- If Main_Project_Only is True, the unit must be an immediate source of
-- Project. If it is False, it may be a source of one of its imported
-- projects.
function Project_Of
(Name : String;
Main_Project : Project_Id)
return Project_Id;
-- Get the project of a source. The source file name may be truncated
-- (".adb" or ".ads" may be missing). If the source is in a project being
-- extended, return the ultimate extending project. If it is not a source
-- of any project, return No_Project.
procedure Get_Reference
(Source_File_Name : String;
Project : out Project_Id;

2
gcc/ada/raise.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* Copyright (C) 1992-2002, Free Software Foundation, Inc. *
* Copyright (C) 1992-2003, 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- *

7
gcc/ada/sem_ch12.adb
View File

@ -7688,7 +7688,6 @@ package body Sem_Ch12 is
or else
Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private
then
-- Check whether the parent is another derived formal type
-- in the same generic unit.
@ -7697,19 +7696,19 @@ package body Sem_Ch12 is
and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T)
and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T)
then
-- Locate ancestor of parent from the subtype declaration
-- created for the actual.
declare
Decl : Node_Id;
begin
Decl := First (Actual_Decls);
while (Present (Decl)) loop
if Nkind (Decl) = N_Subtype_Declaration
and then Chars (Defining_Identifier (Decl))
= Chars (Etype (A_Gen_T))
and then Chars (Defining_Identifier (Decl)) =
Chars (Etype (A_Gen_T))
then
Ancestor := Generic_Parent_Type (Decl);
exit;

83
gcc/ada/sem_ch3.adb
View File

@ -169,8 +169,7 @@ package body Sem_Ch3 is
Derived_Base : Entity_Id;
Is_Tagged : Boolean;
Inherit_Discr : Boolean;
Discs : Elist_Id)
return Elist_Id;
Discs : Elist_Id) return Elist_Id;
-- Called from Build_Derived_Record_Type to inherit the components of
-- Parent_Base (a base type) into the Derived_Base (the derived base type).
-- For more information on derived types and component inheritance please
@ -217,8 +216,7 @@ package body Sem_Ch3 is
function Build_Discriminant_Constraints
(T : Entity_Id;
Def : Node_Id;
Derived_Def : Boolean := False)
return Elist_Id;
Derived_Def : Boolean := False) return Elist_Id;
-- Validate discriminant constraints, and return the list of the
-- constraints in order of discriminant declarations. T is the
-- discriminated unconstrained type. Def is the N_Subtype_Indication
@ -256,8 +254,7 @@ package body Sem_Ch3 is
function Build_Scalar_Bound
(Bound : Node_Id;
Par_T : Entity_Id;
Der_T : Entity_Id)
return Node_Id;
Der_T : Entity_Id) return Node_Id;
-- The bounds of a derived scalar type are conversions of the bounds of
-- the parent type. Optimize the representation if the bounds are literals.
-- Needs a more complete spec--what are the parameters exactly, and what
@ -356,8 +353,7 @@ package body Sem_Ch3 is
Constrained_Typ : Entity_Id;
Related_Node : Node_Id;
Typ : Entity_Id;
Constraints : Elist_Id)
return Entity_Id;
Constraints : Elist_Id) return Entity_Id;
-- Given a discriminated base type Typ, a list of discriminant constraint
-- Constraints for Typ and the type of a component of Typ, Compon_Type,
-- create and return the type corresponding to Compon_type where all
@ -419,8 +415,7 @@ package body Sem_Ch3 is
(Prot_Subt : Entity_Id;
Corr_Rec : Entity_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id)
return Entity_Id;
Related_Id : Entity_Id) return Entity_Id;
-- When constraining a protected type or task type with discriminants,
-- constrain the corresponding record with the same discriminant values.
@ -521,8 +516,7 @@ package body Sem_Ch3 is
function Expand_To_Stored_Constraint
(Typ : Entity_Id;
Constraint : Elist_Id)
return Elist_Id;
Constraint : Elist_Id) return Elist_Id;
-- Given a Constraint (ie a list of expressions) on the discriminants of
-- Typ, expand it into a constraint on the stored discriminants and
-- return the new list of expressions constraining the stored
@ -530,8 +524,7 @@ package body Sem_Ch3 is
function Find_Type_Of_Object
(Obj_Def : Node_Id;
Related_Nod : Node_Id)
return Entity_Id;
Related_Nod : Node_Id) return Entity_Id;
-- Get type entity for object referenced by Obj_Def, attaching the
-- implicit types generated to Related_Nod
@ -546,8 +539,7 @@ package body Sem_Ch3 is
function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind;
Constraint_Kind : Node_Kind)
return Boolean;
Constraint_Kind : Node_Kind) return Boolean;
-- Returns True if it is legal to apply the given kind of constraint
-- to the given kind of type (index constraint to an array type,
-- for example).
@ -670,8 +662,7 @@ package body Sem_Ch3 is
function Access_Definition
(Related_Nod : Node_Id;
N : Node_Id)
return Entity_Id
N : Node_Id) return Entity_Id
is
Anon_Type : constant Entity_Id :=
Create_Itype (E_Anonymous_Access_Type, Related_Nod,
@ -727,6 +718,7 @@ package body Sem_Ch3 is
is
Formals : constant List_Id := Parameter_Specifications (T_Def);
Formal : Entity_Id;
Desig_Type : constant Entity_Id :=
Create_Itype (E_Subprogram_Type, Parent (T_Def));
@ -739,6 +731,7 @@ package body Sem_Ch3 is
Error_Msg_N
("expect type in function specification", Subtype_Mark (T_Def));
end if;
else
Set_Etype (Desig_Type, Standard_Void_Type);
end if;
@ -5322,8 +5315,7 @@ package body Sem_Ch3 is
function Build_Discriminant_Constraints
(T : Entity_Id;
Def : Node_Id;
Derived_Def : Boolean := False)
return Elist_Id
Derived_Def : Boolean := False) return Elist_Id
is
C : constant Node_Id := Constraint (Def);
Nb_Discr : constant Nat := Number_Discriminants (T);
@ -5734,8 +5726,7 @@ package body Sem_Ch3 is
function Build_Scalar_Bound
(Bound : Node_Id;
Par_T : Entity_Id;
Der_T : Entity_Id)
return Node_Id
Der_T : Entity_Id) return Node_Id
is
New_Bound : Entity_Id;
@ -6918,26 +6909,22 @@ package body Sem_Ch3 is
Constrained_Typ : Entity_Id;
Related_Node : Node_Id;
Typ : Entity_Id;
Constraints : Elist_Id)
return Entity_Id
Constraints : Elist_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (Constrained_Typ);
function Build_Constrained_Array_Type
(Old_Type : Entity_Id)
return Entity_Id;
(Old_Type : Entity_Id) return Entity_Id;
-- If Old_Type is an array type, one of whose indices is
-- constrained by a discriminant, build an Itype whose constraint
-- replaces the discriminant with its value in the constraint.
function Build_Constrained_Discriminated_Type
(Old_Type : Entity_Id)
return Entity_Id;
(Old_Type : Entity_Id) return Entity_Id;
-- Ditto for record components.
function Build_Constrained_Access_Type
(Old_Type : Entity_Id)
return Entity_Id;
(Old_Type : Entity_Id) return Entity_Id;
-- Ditto for access types. Makes use of previous two functions, to
-- constrain designated type.
@ -6956,8 +6943,7 @@ package body Sem_Ch3 is
-----------------------------------
function Build_Constrained_Access_Type
(Old_Type : Entity_Id)
return Entity_Id
(Old_Type : Entity_Id) return Entity_Id
is
Desig_Type : constant Entity_Id := Designated_Type (Old_Type);
Itype : Entity_Id;
@ -7043,8 +7029,7 @@ package body Sem_Ch3 is
----------------------------------
function Build_Constrained_Array_Type
(Old_Type : Entity_Id)
return Entity_Id
(Old_Type : Entity_Id) return Entity_Id
is
Lo_Expr : Node_Id;
Hi_Expr : Node_Id;
@ -7104,8 +7089,7 @@ package body Sem_Ch3 is
------------------------------------------
function Build_Constrained_Discriminated_Type
(Old_Type : Entity_Id)
return Entity_Id
(Old_Type : Entity_Id) return Entity_Id
is
Expr : Node_Id;
Constr_List : List_Id;
@ -7374,8 +7358,7 @@ package body Sem_Ch3 is
(Prot_Subt : Entity_Id;
Corr_Rec : Entity_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id)
return Entity_Id
Related_Id : Entity_Id) return Entity_Id
is
T_Sub : constant Entity_Id
:= Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V');
@ -9249,8 +9232,7 @@ package body Sem_Ch3 is
function Expand_To_Stored_Constraint
(Typ : Entity_Id;
Constraint : Elist_Id)
return Elist_Id
Constraint : Elist_Id) return Elist_Id
is
Explicitly_Discriminated_Type : Entity_Id;
Expansion : Elist_Id;
@ -9517,8 +9499,7 @@ package body Sem_Ch3 is
function Find_Type_Of_Object
(Obj_Def : Node_Id;
Related_Nod : Node_Id)
return Entity_Id
Related_Nod : Node_Id) return Entity_Id
is
Def_Kind : constant Node_Kind := Nkind (Obj_Def);
P : constant Node_Id := Parent (Obj_Def);
@ -9810,14 +9791,12 @@ package body Sem_Ch3 is
function Get_Discriminant_Value
(Discriminant : Entity_Id;
Typ_For_Constraint : Entity_Id;
Constraint : Elist_Id)
return Node_Id
Constraint : Elist_Id) return Node_Id
is
function Search_Derivation_Levels
(Ti : Entity_Id;
Discrim_Values : Elist_Id;
Stored_Discrim_Values : Boolean)
return Node_Or_Entity_Id;
Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id;
-- This is the routine that performs the recursive search of levels
-- as described above.
@ -9828,8 +9807,7 @@ package body Sem_Ch3 is
function Search_Derivation_Levels
(Ti : Entity_Id;
Discrim_Values : Elist_Id;
Stored_Discrim_Values : Boolean)
return Node_Or_Entity_Id
Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id
is
Assoc : Elmt_Id;
Disc : Entity_Id;
@ -10051,8 +10029,7 @@ package body Sem_Ch3 is
Derived_Base : Entity_Id;
Is_Tagged : Boolean;
Inherit_Discr : Boolean;
Discs : Elist_Id)
return Elist_Id
Discs : Elist_Id) return Elist_Id
is
Assoc_List : constant Elist_Id := New_Elmt_List;
@ -10288,8 +10265,7 @@ package body Sem_Ch3 is
function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind;
Constraint_Kind : Node_Kind)
return Boolean
Constraint_Kind : Node_Kind) return Boolean
is
begin
case T_Kind is
@ -12003,8 +11979,7 @@ package body Sem_Ch3 is
(S : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
Suffix : Character := ' ')
return Entity_Id
Suffix : Character := ' ') return Entity_Id
is
P : Node_Id;
Def_Id : Entity_Id;

13
gcc/ada/sem_ch3.ads
View File

@ -42,8 +42,7 @@ package Sem_Ch3 is
function Access_Definition
(Related_Nod : Node_Id;
N : Node_Id)
return Entity_Id;
N : Node_Id) return Entity_Id;
-- An access definition defines a general access type for a formal
-- parameter. The procedure is called when processing formals, when
-- the current scope is the subprogram. The Implicit type is attached
@ -129,10 +128,9 @@ package Sem_Ch3 is
-- private type.
function Get_Discriminant_Value
(Discriminant : Entity_Id;
Typ_For_Constraint : Entity_Id;
Constraint : Elist_Id)
return Node_Id;
(Discriminant : Entity_Id;
Typ_For_Constraint : Entity_Id;
Constraint : Elist_Id) return Node_Id;
-- ??? MORE DOCUMENTATION
-- Given a discriminant somewhere in the Typ_For_Constraint tree
-- and a Constraint, return the value of that discriminant.
@ -195,8 +193,7 @@ package Sem_Ch3 is
(S : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
Suffix : Character := ' ')
return Entity_Id;
Suffix : Character := ' ') return Entity_Id;
-- Process a subtype indication S and return corresponding entity.
-- Related_Nod is the node where the potential generated implicit types
-- will be inserted. The Related_Id and Suffix parameters are used to