Skip to content

R
riscv-gcc-1
Commit b0f26df5 by Arnaud Charlet
Options

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
parent bf22935f
Showing with 571 additions and 102 deletions
gcc/ada/Make-lang.in
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/Makefile.generic
...@@ -47,6 +47,7 @@ ...@@ -47,6 +47,7 @@
# CXX name of the C++ compiler (optional, default to gcc) # CXX name of the C++ compiler (optional, default to gcc)
# AR_CMD command to create an archive (optional, default to "ar rc") # AR_CMD command to create an archive (optional, default to "ar rc")
# AR_EXT file extension of an archive (optional, default to ".a") # 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") # GNATMAKE name of the GNAT builder (optional, default to "gnatmake")
# ADAFLAGS additional Ada compilation switches, e.g "-gnatf" (optional) # ADAFLAGS additional Ada compilation switches, e.g "-gnatf" (optional)
# CFLAGS default C compilation switches, e.g "-O2 -g" (optional) # CFLAGS default C compilation switches, e.g "-O2 -g" (optional)
...@@ -56,6 +57,7 @@ ...@@ -56,6 +57,7 @@
# ADA_SOURCES list of main Ada sources (optional) # ADA_SOURCES list of main Ada sources (optional)
# EXEC name of the final executable (optional) # EXEC name of the final executable (optional)
# MAIN language of the main program (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 # PROJECT_FILE name of the project file, without the .gpr extension
# DEPS_PROJECTS list of project dependencies (optional) # DEPS_PROJECTS list of project dependencies (optional)
...@@ -65,6 +67,10 @@ ifndef MAIN ...@@ -65,6 +67,10 @@ ifndef MAIN
MAIN=ada MAIN=ada
endif endif
ifndef CC
CC=gcc
endif
ifndef ADA_SPEC ifndef ADA_SPEC
ADA_SPEC=.ads ADA_SPEC=.ads
endif endif
...@@ -100,10 +106,18 @@ ifndef AR_CMD ...@@ -100,10 +106,18 @@ ifndef AR_CMD
AR_CMD=ar rc AR_CMD=ar rc
endif endif
ifndef RANLIB
RANLIB=ranlib
endif
ifndef GNATMAKE ifndef GNATMAKE
GNATMAKE=gnatmake GNATMAKE=gnatmake
endif endif
ifndef ARCHIVE
ARCHIVE=$(OBJ_DIR)/lib$(PROJECT_BASE)-full$(AR_EXT)
endif
ifeq ($(EXEC_DIR),) ifeq ($(EXEC_DIR),)
EXEC_DIR=$(OBJ_DIR) EXEC_DIR=$(OBJ_DIR)
endif endif
...@@ -120,6 +134,7 @@ vpath %$(AR_EXT) $(OBJ_DIR) ...@@ -120,6 +134,7 @@ vpath %$(AR_EXT) $(OBJ_DIR)
clean_deps = $(subst :,|,$(DEPS_PROJECTS:%=clean_%)) clean_deps = $(subst :,|,$(DEPS_PROJECTS:%=clean_%))
compile_deps = $(subst :,|,$(DEPS_PROJECTS:%=compile_%)) compile_deps = $(subst :,|,$(DEPS_PROJECTS:%=compile_%))
object_deps = $(subst :,|,$(DEPS_PROJECTS:%=object_%))
ada_deps = $(subst :,|,$(DEPS_PROJECTS:%=ada_%)) ada_deps = $(subst :,|,$(DEPS_PROJECTS:%=ada_%))
c_deps = $(subst :,|,$(DEPS_PROJECTS:%=c_%)) c_deps = $(subst :,|,$(DEPS_PROJECTS:%=c_%))
c++_deps = $(subst :,|,$(DEPS_PROJECTS:%=c++_%)) c++_deps = $(subst :,|,$(DEPS_PROJECTS:%=c++_%))
...@@ -131,6 +146,7 @@ clean: $(clean_deps) internal-clean ...@@ -131,6 +146,7 @@ clean: $(clean_deps) internal-clean
build: $(compile_deps) internal-compile internal-build build: $(compile_deps) internal-compile internal-build
compile: $(compile_deps) internal-compile $(ADA_SOURCES) compile: $(compile_deps) internal-compile $(ADA_SOURCES)
ada: $(ada_deps) internal-ada ada: $(ada_deps) internal-ada
archive-objects: $(object_deps) internal-archive-objects
c: $(c_deps) internal-c c: $(c_deps) internal-c
c++: $(c++deps) internal-c++ c++: $(c++deps) internal-c++
...@@ -140,6 +156,9 @@ $(clean_deps): force ...@@ -140,6 +156,9 @@ $(clean_deps): force
$(compile_deps): force $(compile_deps): force
@$(MAKE) -C $(dir $(subst |,:,$(@:compile_%=%))) -f Makefile.$(notdir $@) internal-compile @$(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 $(ada_deps): force
@$(MAKE) -C $(dir $(subst |,:,$(@:ada_%=%))) -f Makefile.$(notdir $@) internal-ada @$(MAKE) -C $(dir $(subst |,:,$(@:ada_%=%))) -f Makefile.$(notdir $@) internal-ada
...@@ -238,6 +257,7 @@ DEP_FILES := $(OBJ_FILES:$(OBJ_EXT)=.d) ...@@ -238,6 +257,7 @@ DEP_FILES := $(OBJ_FILES:$(OBJ_EXT)=.d)
ifeq ($(strip $(OBJECTS)),) ifeq ($(strip $(OBJECTS)),)
internal-compile: internal-compile:
internal-archive-objects:
else else
internal-compile: lib$(PROJECT_BASE)$(AR_EXT) internal-compile: lib$(PROJECT_BASE)$(AR_EXT)
...@@ -245,7 +265,13 @@ internal-compile: lib$(PROJECT_BASE)$(AR_EXT) ...@@ -245,7 +265,13 @@ internal-compile: lib$(PROJECT_BASE)$(AR_EXT)
lib$(PROJECT_BASE)$(AR_EXT): $(OBJECTS) lib$(PROJECT_BASE)$(AR_EXT): $(OBJECTS)
@echo creating archive file for $(PROJECT_BASE) @echo creating archive file for $(PROJECT_BASE)
cd $(OBJ_DIR); $(AR_CMD) $@ $(strip $(OBJECTS)) 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 endif
# Linking rules # Linking rules
...@@ -260,9 +286,24 @@ endif ...@@ -260,9 +286,24 @@ endif
ifeq ($(strip $(filter-out c c++,$(LANGUAGES))),) ifeq ($(strip $(filter-out c c++,$(LANGUAGES))),)
# link with C/C++ # 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) $(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 internal-build: internal-compile link
...@@ -272,11 +313,11 @@ ifeq ($(strip $(filter-out c c++ ada,$(LANGUAGES))),) ...@@ -272,11 +313,11 @@ ifeq ($(strip $(filter-out c c++ ada,$(LANGUAGES))),)
ifeq ($(MAIN),ada) ifeq ($(MAIN),ada)
# Ada main # Ada main
link: $(LINKER) force link: $(LINKER) archive-objects force
$(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \ $(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(LARGS) $(LDFLAGS) -largs $(LARGS) $(LDFLAGS)
internal-build: $(LINKER) force internal-build: $(LINKER) archive-objects force
@echo $(GNATMAKE) -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS) @echo $(GNATMAKE) -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) -P$(PROJECT_FILE) $(EXEC_RULE) $(ADA_SOURCES) $(ADAFLAGS) \ @$(GNATMAKE) -P$(PROJECT_FILE) $(EXEC_RULE) $(ADA_SOURCES) $(ADAFLAGS) \
-largs $(LARGS) $(LDFLAGS) -largs $(LARGS) $(LDFLAGS)
...@@ -288,11 +329,11 @@ else ...@@ -288,11 +329,11 @@ else
# close enough to our needs, and the usual -n gnatbind switch and --LINK= # close enough to our needs, and the usual -n gnatbind switch and --LINK=
# gnatlink switch. # gnatlink switch.
link: $(LINKER) force link: $(LINKER) archive-objects force
$(GNATMAKE) $(EXEC_RULE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) \ $(GNATMAKE) $(EXEC_RULE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) \
-bargs -n -largs $(LARGS) $(LDFLAGS) -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) @echo $(GNATMAKE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) $(EXEC_RULE) -z \ @$(GNATMAKE) $(EXEC_RULE) -z \
-P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \ -P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
...@@ -385,7 +426,7 @@ internal-c : $(C_OBJECTS) ...@@ -385,7 +426,7 @@ internal-c : $(C_OBJECTS)
# Compile all C++ files in the project # Compile all C++ files in the project
internal-c++ : $(CXX_OBJECTS) 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: internal-clean:
@echo $(RM) $(OBJ_DIR)/*$(OBJ_EXT) @echo $(RM) $(OBJ_DIR)/*$(OBJ_EXT)
......
gcc/ada/adadecode.c
...@@ -2,11 +2,11 @@ ...@@ -2,11 +2,11 @@
* * * *
* GNAT COMPILER COMPONENTS * * GNAT COMPILER COMPONENTS *
* * * *
* G N A T D E C O * * A D A D E C O D E *
* * * *
* C Implementation File * * 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 * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -42,8 +42,12 @@ ...@@ -42,8 +42,12 @@
#include "adadecode.h" #include "adadecode.h"
static void add_verbose PARAMS ((const char *, char *)); static void add_verbose PARAMS ((const char *, char *));
static int has_prefix PARAMS ((char *, const char *)); static int has_prefix PARAMS ((const char *, const char *));
static int has_suffix PARAMS ((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. */ /* Set to nonzero if we have written any verbose info. */
static int verbose_info; static int verbose_info;
...@@ -65,7 +69,7 @@ static void add_verbose (text, ada_name) ...@@ -65,7 +69,7 @@ static void add_verbose (text, ada_name)
static int static int
has_prefix (name, prefix) has_prefix (name, prefix)
char *name; const char *name;
const char *prefix; const char *prefix;
{ {
return strncmp (name, prefix, strlen (prefix)) == 0; return strncmp (name, prefix, strlen (prefix)) == 0;
...@@ -75,7 +79,7 @@ has_prefix (name, prefix) ...@@ -75,7 +79,7 @@ has_prefix (name, prefix)
static int static int
has_suffix (name, suffix) has_suffix (name, suffix)
char *name; const char *name;
const char *suffix; const char *suffix;
{ {
int nlen = strlen (name); int nlen = strlen (name);
...@@ -84,6 +88,18 @@ has_suffix (name, suffix) ...@@ -84,6 +88,18 @@ has_suffix (name, suffix)
return nlen > slen && strncmp (name + nlen - slen, suffix, slen) == 0; 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. /* 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. 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 see exp_dbug.ads for full encoding rules, a short description is added
...@@ -142,16 +158,14 @@ __gnat_decode (coded_name, ada_name, verbose) ...@@ -142,16 +158,14 @@ __gnat_decode (coded_name, ada_name, verbose)
int in_task = 0; int in_task = 0;
int body_nested = 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. */ /* 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; lib_subprog = 1;
} }
else
strcpy (ada_name, coded_name);
/* Check for task body. */ /* Check for task body. */
if (has_suffix (ada_name, "TKB")) if (has_suffix (ada_name, "TKB"))
...@@ -191,7 +205,7 @@ __gnat_decode (coded_name, ada_name, verbose) ...@@ -191,7 +205,7 @@ __gnat_decode (coded_name, ada_name, verbose)
while ((tktoken = (char *) strstr (ada_name, "TK__")) != NULL) while ((tktoken = (char *) strstr (ada_name, "TK__")) != NULL)
{ {
strcpy (tktoken, tktoken + 2); ostrcpy (tktoken, tktoken + 2);
in_task = 1; in_task = 1;
} }
} }
...@@ -229,7 +243,7 @@ __gnat_decode (coded_name, ada_name, verbose) ...@@ -229,7 +243,7 @@ __gnat_decode (coded_name, ada_name, verbose)
if (ada_name[k] == '_' && ada_name[k+1] == '_') if (ada_name[k] == '_' && ada_name[k+1] == '_')
{ {
ada_name[k] = '.'; ada_name[k] = '.';
strcpy (ada_name + k + 1, ada_name + k + 2); ostrcpy (ada_name + k + 1, ada_name + k + 2);
len = len - 1; len = len - 1;
} }
k++; k++;
...@@ -259,7 +273,7 @@ __gnat_decode (coded_name, ada_name, verbose) ...@@ -259,7 +273,7 @@ __gnat_decode (coded_name, ada_name, verbose)
if (codedlen > oplen) if (codedlen > oplen)
/* We shrink the space. */ /* We shrink the space. */
strcpy (optoken, optoken + codedlen - oplen); ostrcpy (optoken, optoken + codedlen - oplen);
else if (oplen > codedlen) else if (oplen > codedlen)
{ {
/* We need more space. */ /* We need more space. */
......
gcc/ada/adadecode.h
...@@ -2,11 +2,11 @@ ...@@ -2,11 +2,11 @@
* * * *
* GNAT COMPILER COMPONENTS * * GNAT COMPILER COMPONENTS *
* * * *
* G N A T D E C O * * A D A D E C O D E *
* * * *
* C Header File * * 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 * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
......
gcc/ada/atree.h
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Header File * * 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 * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
......
gcc/ada/elists.h
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Header File * * 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 * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
......
gcc/ada/exp_disp.adb
...@@ -922,11 +922,10 @@ package body Exp_Disp is ...@@ -922,11 +922,10 @@ package body Exp_Disp is
-- Register_Tag (Dt_Ptr); -- 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) if RTE_Available (RE_Register_Tag)
and then Is_RTE (Generalized_Tag, RE_Tag) and then Is_RTE (Generalized_Tag, RE_Tag)
and then not No_Run_Time_Mode
then then
Append_To (Elab_Code, Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
......
gcc/ada/g-catiio.adb
...@@ -44,7 +44,7 @@ package body GNAT.Calendar.Time_IO is ...@@ -44,7 +44,7 @@ package body GNAT.Calendar.Time_IO is
type Month_Name is type Month_Name is
(January, (January,
Febuary, February,
March, March,
April, April,
May, May,
......
gcc/ada/make.adb
...@@ -28,6 +28,7 @@ with Ada.Exceptions; use Ada.Exceptions; ...@@ -28,6 +28,7 @@ with Ada.Exceptions; use Ada.Exceptions;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Command_Line; use Ada.Command_Line;
with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Case_Util; use GNAT.Case_Util;
with ALI; use ALI; with ALI; use ALI;
with ALI.Util; use ALI.Util; with ALI.Util; use ALI.Util;
...@@ -178,6 +179,31 @@ package body Make is ...@@ -178,6 +179,31 @@ package body Make is
Table_Name => "Make.Q"); Table_Name => "Make.Q");
-- This is the actual 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 -- The following instantiations and variables are necessary to save what
-- is found on the command line, in case there is a project file specified. -- is found on the command line, in case there is a project file specified.
...@@ -3340,6 +3366,147 @@ package body Make is ...@@ -3340,6 +3366,147 @@ package body Make is
if Projects.Table (Main_Project).Library then if Projects.Table (Main_Project).Library then
Make_Failed ("cannot specify a main program " & Make_Failed ("cannot specify a main program " &
"on the command line for a library project file"); "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; end if;
-- If no mains have been specified on the command line, -- If no mains have been specified on the command line,
...@@ -3383,14 +3550,93 @@ package body Make is ...@@ -3383,14 +3550,93 @@ package body Make is
else else
-- The attribute Main is not an empty list. -- The attribute Main is not an empty list.
-- Put all the main subprograms in the list as if there -- 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.
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 while Value /= Prj.Nil_String loop
Get_Name_String (String_Elements.Table (Value).Value); Get_Name_String (String_Elements.Table (Value).Value);
Osint.Add_File (Name_Buffer (1 .. Name_Len));
-- 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; Value := String_Elements.Table (Value).Next;
end loop; 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 if;
end; end;
end if; end if;
...@@ -5256,6 +5502,8 @@ package body Make is ...@@ -5256,6 +5502,8 @@ package body Make is
RTS_Specified := null; RTS_Specified := null;
Mains.Delete;
Next_Arg := 1; Next_Arg := 1;
Scan_Args : while Next_Arg <= Argument_Count loop Scan_Args : while Next_Arg <= Argument_Count loop
Scan_Make_Arg (Argument (Next_Arg), And_Save => True); Scan_Make_Arg (Argument (Next_Arg), And_Save => True);
...@@ -5850,6 +6098,68 @@ package body Make is ...@@ -5850,6 +6098,68 @@ package body Make is
Set_Standard_Error; Set_Standard_Error;
end List_Depend; 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 -- -- Mark --
---------- ----------
...@@ -6521,6 +6831,7 @@ package body Make is ...@@ -6521,6 +6831,7 @@ package body Make is
else else
Add_File (Argv); Add_File (Argv);
Mains.Add_Main (Argv);
end if; end if;
end Scan_Make_Arg; end Scan_Make_Arg;
......
gcc/ada/nlists.h
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Header File * * 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 * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
......
gcc/ada/prj-env.adb
...@@ -1060,7 +1060,8 @@ package body Prj.Env is ...@@ -1060,7 +1060,8 @@ package body Prj.Env is
function File_Name_Of_Library_Unit_Body function File_Name_Of_Library_Unit_Body
(Name : String; (Name : String;
Project : Project_Id; Project : Project_Id;
Main_Project_Only : Boolean := True) Main_Project_Only : Boolean := True;
Full_Path : Boolean := False)
return String return String
is is
The_Project : Project_Id := Project; The_Project : Project_Id := Project;
...@@ -1151,7 +1152,13 @@ package body Prj.Env is ...@@ -1151,7 +1152,13 @@ package body Prj.Env is
Write_Line (" OK"); Write_Line (" OK");
end if; end if;
if Full_Path then
return Get_Name_String
(Unit.File_Names (Body_Part).Path);
else
return Get_Name_String (Current_Name); return Get_Name_String (Current_Name);
end if;
-- If it has the name of the extended body name, -- If it has the name of the extended body name,
-- return the extended body name -- return the extended body name
...@@ -1161,7 +1168,13 @@ package body Prj.Env is ...@@ -1161,7 +1168,13 @@ package body Prj.Env is
Write_Line (" OK"); Write_Line (" OK");
end if; end if;
if Full_Path then
return Get_Name_String
(Unit.File_Names (Body_Part).Path);
else
return Extended_Body_Name; return Extended_Body_Name;
end if;
else else
if Current_Verbosity = High then if Current_Verbosity = High then
...@@ -1202,7 +1215,14 @@ package body Prj.Env is ...@@ -1202,7 +1215,14 @@ package body Prj.Env is
Write_Line (" OK"); Write_Line (" OK");
end if; end if;
if Full_Path then
return Get_Name_String
(Unit.File_Names (Specification).Path);
else
return Get_Name_String (Current_Name); return Get_Name_String (Current_Name);
end if;
-- If it has the same name as the extended spec name, -- If it has the same name as the extended spec name,
-- return the extended spec name. -- return the extended spec name.
...@@ -1212,7 +1232,13 @@ package body Prj.Env is ...@@ -1212,7 +1232,13 @@ package body Prj.Env is
Write_Line (" OK"); Write_Line (" OK");
end if; end if;
if Full_Path then
return Get_Name_String
(Unit.File_Names (Specification).Path);
else
return Extended_Spec_Name; return Extended_Spec_Name;
end if;
else else
if Current_Verbosity = High then if Current_Verbosity = High then
...@@ -1701,6 +1727,101 @@ package body Prj.Env is ...@@ -1701,6 +1727,101 @@ package body Prj.Env is
Write_Line ("end of List of Sources."); Write_Line ("end of List of Sources.");
end Print_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 -- -- Set_Ada_Paths --
------------------- -------------------
......
gcc/ada/prj-env.ads
...@@ -101,17 +101,29 @@ package Prj.Env is ...@@ -101,17 +101,29 @@ package Prj.Env is
function File_Name_Of_Library_Unit_Body function File_Name_Of_Library_Unit_Body
(Name : String; (Name : String;
Project : Project_Id; Project : Project_Id;
Main_Project_Only : Boolean := True) Main_Project_Only : Boolean := True;
Full_Path : Boolean := False)
return String; return String;
-- Returns the file name of a library unit, in canonical case. Name may or -- 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 -- 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 -- 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, -- name of the spec is returned.
-- return an empty string. -- 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 -- 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 -- Project. If it is False, it may be a source of one of its imported
-- projects. -- 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 procedure Get_Reference
(Source_File_Name : String; (Source_File_Name : String;
Project : out Project_Id; Project : out Project_Id;
......
gcc/ada/raise.h
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Header File * * 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 * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
......
gcc/ada/sem_ch12.adb
...@@ -7688,7 +7688,6 @@ package body Sem_Ch12 is ...@@ -7688,7 +7688,6 @@ package body Sem_Ch12 is
or else or else
Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private
then then
-- Check whether the parent is another derived formal type -- Check whether the parent is another derived formal type
-- in the same generic unit. -- in the same generic unit.
...@@ -7697,19 +7696,19 @@ package body Sem_Ch12 is ...@@ -7697,19 +7696,19 @@ package body Sem_Ch12 is
and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T) and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T)
and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T) and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T)
then then
-- Locate ancestor of parent from the subtype declaration -- Locate ancestor of parent from the subtype declaration
-- created for the actual. -- created for the actual.
declare declare
Decl : Node_Id; Decl : Node_Id;
begin begin
Decl := First (Actual_Decls); Decl := First (Actual_Decls);
while (Present (Decl)) loop while (Present (Decl)) loop
if Nkind (Decl) = N_Subtype_Declaration if Nkind (Decl) = N_Subtype_Declaration
and then Chars (Defining_Identifier (Decl)) and then Chars (Defining_Identifier (Decl)) =
= Chars (Etype (A_Gen_T)) Chars (Etype (A_Gen_T))
then then
Ancestor := Generic_Parent_Type (Decl); Ancestor := Generic_Parent_Type (Decl);
exit; exit;
......
gcc/ada/sem_ch3.adb
...@@ -169,8 +169,7 @@ package body Sem_Ch3 is ...@@ -169,8 +169,7 @@ package body Sem_Ch3 is
Derived_Base : Entity_Id; Derived_Base : Entity_Id;
Is_Tagged : Boolean; Is_Tagged : Boolean;
Inherit_Discr : Boolean; Inherit_Discr : Boolean;
Discs : Elist_Id) Discs : Elist_Id) return Elist_Id;
return Elist_Id;
-- Called from Build_Derived_Record_Type to inherit the components of -- Called from Build_Derived_Record_Type to inherit the components of
-- Parent_Base (a base type) into the Derived_Base (the derived base type). -- Parent_Base (a base type) into the Derived_Base (the derived base type).
-- For more information on derived types and component inheritance please -- For more information on derived types and component inheritance please
...@@ -217,8 +216,7 @@ package body Sem_Ch3 is ...@@ -217,8 +216,7 @@ package body Sem_Ch3 is
function Build_Discriminant_Constraints function Build_Discriminant_Constraints
(T : Entity_Id; (T : Entity_Id;
Def : Node_Id; Def : Node_Id;
Derived_Def : Boolean := False) Derived_Def : Boolean := False) return Elist_Id;
return Elist_Id;
-- Validate discriminant constraints, and return the list of the -- Validate discriminant constraints, and return the list of the
-- constraints in order of discriminant declarations. T is the -- constraints in order of discriminant declarations. T is the
-- discriminated unconstrained type. Def is the N_Subtype_Indication -- discriminated unconstrained type. Def is the N_Subtype_Indication
...@@ -256,8 +254,7 @@ package body Sem_Ch3 is ...@@ -256,8 +254,7 @@ package body Sem_Ch3 is
function Build_Scalar_Bound function Build_Scalar_Bound
(Bound : Node_Id; (Bound : Node_Id;
Par_T : Entity_Id; Par_T : Entity_Id;
Der_T : Entity_Id) Der_T : Entity_Id) return Node_Id;
return Node_Id;
-- The bounds of a derived scalar type are conversions of the bounds of -- The bounds of a derived scalar type are conversions of the bounds of
-- the parent type. Optimize the representation if the bounds are literals. -- the parent type. Optimize the representation if the bounds are literals.
-- Needs a more complete spec--what are the parameters exactly, and what -- Needs a more complete spec--what are the parameters exactly, and what
...@@ -356,8 +353,7 @@ package body Sem_Ch3 is ...@@ -356,8 +353,7 @@ package body Sem_Ch3 is
Constrained_Typ : Entity_Id; Constrained_Typ : Entity_Id;
Related_Node : Node_Id; Related_Node : Node_Id;
Typ : Entity_Id; Typ : Entity_Id;
Constraints : Elist_Id) Constraints : Elist_Id) return Entity_Id;
return Entity_Id;
-- Given a discriminated base type Typ, a list of discriminant constraint -- Given a discriminated base type Typ, a list of discriminant constraint
-- Constraints for Typ and the type of a component of Typ, Compon_Type, -- Constraints for Typ and the type of a component of Typ, Compon_Type,
-- create and return the type corresponding to Compon_type where all -- create and return the type corresponding to Compon_type where all
...@@ -419,8 +415,7 @@ package body Sem_Ch3 is ...@@ -419,8 +415,7 @@ package body Sem_Ch3 is
(Prot_Subt : Entity_Id; (Prot_Subt : Entity_Id;
Corr_Rec : Entity_Id; Corr_Rec : Entity_Id;
Related_Nod : Node_Id; Related_Nod : Node_Id;
Related_Id : Entity_Id) Related_Id : Entity_Id) return Entity_Id;
return Entity_Id;
-- When constraining a protected type or task type with discriminants, -- When constraining a protected type or task type with discriminants,
-- constrain the corresponding record with the same discriminant values. -- constrain the corresponding record with the same discriminant values.
...@@ -521,8 +516,7 @@ package body Sem_Ch3 is ...@@ -521,8 +516,7 @@ package body Sem_Ch3 is
function Expand_To_Stored_Constraint function Expand_To_Stored_Constraint
(Typ : Entity_Id; (Typ : Entity_Id;
Constraint : Elist_Id) Constraint : Elist_Id) return Elist_Id;
return Elist_Id;
-- Given a Constraint (ie a list of expressions) on the discriminants of -- Given a Constraint (ie a list of expressions) on the discriminants of
-- Typ, expand it into a constraint on the stored discriminants and -- Typ, expand it into a constraint on the stored discriminants and
-- return the new list of expressions constraining the stored -- return the new list of expressions constraining the stored
...@@ -530,8 +524,7 @@ package body Sem_Ch3 is ...@@ -530,8 +524,7 @@ package body Sem_Ch3 is
function Find_Type_Of_Object function Find_Type_Of_Object
(Obj_Def : Node_Id; (Obj_Def : Node_Id;
Related_Nod : Node_Id) Related_Nod : Node_Id) return Entity_Id;
return Entity_Id;
-- Get type entity for object referenced by Obj_Def, attaching the -- Get type entity for object referenced by Obj_Def, attaching the
-- implicit types generated to Related_Nod -- implicit types generated to Related_Nod
...@@ -546,8 +539,7 @@ package body Sem_Ch3 is ...@@ -546,8 +539,7 @@ package body Sem_Ch3 is
function Is_Valid_Constraint_Kind function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind; (T_Kind : Type_Kind;
Constraint_Kind : Node_Kind) Constraint_Kind : Node_Kind) return Boolean;
return Boolean;
-- Returns True if it is legal to apply the given kind of constraint -- 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, -- to the given kind of type (index constraint to an array type,
-- for example). -- for example).
...@@ -670,8 +662,7 @@ package body Sem_Ch3 is ...@@ -670,8 +662,7 @@ package body Sem_Ch3 is
function Access_Definition function Access_Definition
(Related_Nod : Node_Id; (Related_Nod : Node_Id;
N : Node_Id) N : Node_Id) return Entity_Id
return Entity_Id
is is
Anon_Type : constant Entity_Id := Anon_Type : constant Entity_Id :=
Create_Itype (E_Anonymous_Access_Type, Related_Nod, Create_Itype (E_Anonymous_Access_Type, Related_Nod,
...@@ -727,6 +718,7 @@ package body Sem_Ch3 is ...@@ -727,6 +718,7 @@ package body Sem_Ch3 is
is is
Formals : constant List_Id := Parameter_Specifications (T_Def); Formals : constant List_Id := Parameter_Specifications (T_Def);
Formal : Entity_Id; Formal : Entity_Id;
Desig_Type : constant Entity_Id := Desig_Type : constant Entity_Id :=
Create_Itype (E_Subprogram_Type, Parent (T_Def)); Create_Itype (E_Subprogram_Type, Parent (T_Def));
...@@ -739,6 +731,7 @@ package body Sem_Ch3 is ...@@ -739,6 +731,7 @@ package body Sem_Ch3 is
Error_Msg_N Error_Msg_N
("expect type in function specification", Subtype_Mark (T_Def)); ("expect type in function specification", Subtype_Mark (T_Def));
end if; end if;
else else
Set_Etype (Desig_Type, Standard_Void_Type); Set_Etype (Desig_Type, Standard_Void_Type);
end if; end if;
...@@ -5322,8 +5315,7 @@ package body Sem_Ch3 is ...@@ -5322,8 +5315,7 @@ package body Sem_Ch3 is
function Build_Discriminant_Constraints function Build_Discriminant_Constraints
(T : Entity_Id; (T : Entity_Id;
Def : Node_Id; Def : Node_Id;
Derived_Def : Boolean := False) Derived_Def : Boolean := False) return Elist_Id
return Elist_Id
is is
C : constant Node_Id := Constraint (Def); C : constant Node_Id := Constraint (Def);
Nb_Discr : constant Nat := Number_Discriminants (T); Nb_Discr : constant Nat := Number_Discriminants (T);
...@@ -5734,8 +5726,7 @@ package body Sem_Ch3 is ...@@ -5734,8 +5726,7 @@ package body Sem_Ch3 is
function Build_Scalar_Bound function Build_Scalar_Bound
(Bound : Node_Id; (Bound : Node_Id;
Par_T : Entity_Id; Par_T : Entity_Id;
Der_T : Entity_Id) Der_T : Entity_Id) return Node_Id
return Node_Id
is is
New_Bound : Entity_Id; New_Bound : Entity_Id;
...@@ -6918,26 +6909,22 @@ package body Sem_Ch3 is ...@@ -6918,26 +6909,22 @@ package body Sem_Ch3 is
Constrained_Typ : Entity_Id; Constrained_Typ : Entity_Id;
Related_Node : Node_Id; Related_Node : Node_Id;
Typ : Entity_Id; Typ : Entity_Id;
Constraints : Elist_Id) Constraints : Elist_Id) return Entity_Id
return Entity_Id
is is
Loc : constant Source_Ptr := Sloc (Constrained_Typ); Loc : constant Source_Ptr := Sloc (Constrained_Typ);
function Build_Constrained_Array_Type function Build_Constrained_Array_Type
(Old_Type : Entity_Id) (Old_Type : Entity_Id) return Entity_Id;
return Entity_Id;
-- If Old_Type is an array type, one of whose indices is -- If Old_Type is an array type, one of whose indices is
-- constrained by a discriminant, build an Itype whose constraint -- constrained by a discriminant, build an Itype whose constraint
-- replaces the discriminant with its value in the constraint. -- replaces the discriminant with its value in the constraint.
function Build_Constrained_Discriminated_Type function Build_Constrained_Discriminated_Type
(Old_Type : Entity_Id) (Old_Type : Entity_Id) return Entity_Id;
return Entity_Id;
-- Ditto for record components. -- Ditto for record components.
function Build_Constrained_Access_Type function Build_Constrained_Access_Type
(Old_Type : Entity_Id) (Old_Type : Entity_Id) return Entity_Id;
return Entity_Id;
-- Ditto for access types. Makes use of previous two functions, to -- Ditto for access types. Makes use of previous two functions, to
-- constrain designated type. -- constrain designated type.
...@@ -6956,8 +6943,7 @@ package body Sem_Ch3 is ...@@ -6956,8 +6943,7 @@ package body Sem_Ch3 is
----------------------------------- -----------------------------------
function Build_Constrained_Access_Type function Build_Constrained_Access_Type
(Old_Type : Entity_Id) (Old_Type : Entity_Id) return Entity_Id
return Entity_Id
is is
Desig_Type : constant Entity_Id := Designated_Type (Old_Type); Desig_Type : constant Entity_Id := Designated_Type (Old_Type);
Itype : Entity_Id; Itype : Entity_Id;
...@@ -7043,8 +7029,7 @@ package body Sem_Ch3 is ...@@ -7043,8 +7029,7 @@ package body Sem_Ch3 is
---------------------------------- ----------------------------------
function Build_Constrained_Array_Type function Build_Constrained_Array_Type
(Old_Type : Entity_Id) (Old_Type : Entity_Id) return Entity_Id
return Entity_Id
is is
Lo_Expr : Node_Id; Lo_Expr : Node_Id;
Hi_Expr : Node_Id; Hi_Expr : Node_Id;
...@@ -7104,8 +7089,7 @@ package body Sem_Ch3 is ...@@ -7104,8 +7089,7 @@ package body Sem_Ch3 is
------------------------------------------ ------------------------------------------
function Build_Constrained_Discriminated_Type function Build_Constrained_Discriminated_Type
(Old_Type : Entity_Id) (Old_Type : Entity_Id) return Entity_Id
return Entity_Id
is is
Expr : Node_Id; Expr : Node_Id;
Constr_List : List_Id; Constr_List : List_Id;
...@@ -7374,8 +7358,7 @@ package body Sem_Ch3 is ...@@ -7374,8 +7358,7 @@ package body Sem_Ch3 is
(Prot_Subt : Entity_Id; (Prot_Subt : Entity_Id;
Corr_Rec : Entity_Id; Corr_Rec : Entity_Id;
Related_Nod : Node_Id; Related_Nod : Node_Id;
Related_Id : Entity_Id) Related_Id : Entity_Id) return Entity_Id
return Entity_Id
is is
T_Sub : constant Entity_Id T_Sub : constant Entity_Id
:= Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V'); := Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V');
...@@ -9249,8 +9232,7 @@ package body Sem_Ch3 is ...@@ -9249,8 +9232,7 @@ package body Sem_Ch3 is
function Expand_To_Stored_Constraint function Expand_To_Stored_Constraint
(Typ : Entity_Id; (Typ : Entity_Id;
Constraint : Elist_Id) Constraint : Elist_Id) return Elist_Id
return Elist_Id
is is
Explicitly_Discriminated_Type : Entity_Id; Explicitly_Discriminated_Type : Entity_Id;
Expansion : Elist_Id; Expansion : Elist_Id;
...@@ -9517,8 +9499,7 @@ package body Sem_Ch3 is ...@@ -9517,8 +9499,7 @@ package body Sem_Ch3 is
function Find_Type_Of_Object function Find_Type_Of_Object
(Obj_Def : Node_Id; (Obj_Def : Node_Id;
Related_Nod : Node_Id) Related_Nod : Node_Id) return Entity_Id
return Entity_Id
is is
Def_Kind : constant Node_Kind := Nkind (Obj_Def); Def_Kind : constant Node_Kind := Nkind (Obj_Def);
P : constant Node_Id := Parent (Obj_Def); P : constant Node_Id := Parent (Obj_Def);
...@@ -9810,14 +9791,12 @@ package body Sem_Ch3 is ...@@ -9810,14 +9791,12 @@ package body Sem_Ch3 is
function Get_Discriminant_Value function Get_Discriminant_Value
(Discriminant : Entity_Id; (Discriminant : Entity_Id;
Typ_For_Constraint : Entity_Id; Typ_For_Constraint : Entity_Id;
Constraint : Elist_Id) Constraint : Elist_Id) return Node_Id
return Node_Id
is is
function Search_Derivation_Levels function Search_Derivation_Levels
(Ti : Entity_Id; (Ti : Entity_Id;
Discrim_Values : Elist_Id; Discrim_Values : Elist_Id;
Stored_Discrim_Values : Boolean) Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id;
return Node_Or_Entity_Id;
-- This is the routine that performs the recursive search of levels -- This is the routine that performs the recursive search of levels
-- as described above. -- as described above.
...@@ -9828,8 +9807,7 @@ package body Sem_Ch3 is ...@@ -9828,8 +9807,7 @@ package body Sem_Ch3 is
function Search_Derivation_Levels function Search_Derivation_Levels
(Ti : Entity_Id; (Ti : Entity_Id;
Discrim_Values : Elist_Id; Discrim_Values : Elist_Id;
Stored_Discrim_Values : Boolean) Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id
return Node_Or_Entity_Id
is is
Assoc : Elmt_Id; Assoc : Elmt_Id;
Disc : Entity_Id; Disc : Entity_Id;
...@@ -10051,8 +10029,7 @@ package body Sem_Ch3 is ...@@ -10051,8 +10029,7 @@ package body Sem_Ch3 is
Derived_Base : Entity_Id; Derived_Base : Entity_Id;
Is_Tagged : Boolean; Is_Tagged : Boolean;
Inherit_Discr : Boolean; Inherit_Discr : Boolean;
Discs : Elist_Id) Discs : Elist_Id) return Elist_Id
return Elist_Id
is is
Assoc_List : constant Elist_Id := New_Elmt_List; Assoc_List : constant Elist_Id := New_Elmt_List;
...@@ -10288,8 +10265,7 @@ package body Sem_Ch3 is ...@@ -10288,8 +10265,7 @@ package body Sem_Ch3 is
function Is_Valid_Constraint_Kind function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind; (T_Kind : Type_Kind;
Constraint_Kind : Node_Kind) Constraint_Kind : Node_Kind) return Boolean
return Boolean
is is
begin begin
case T_Kind is case T_Kind is
...@@ -12003,8 +11979,7 @@ package body Sem_Ch3 is ...@@ -12003,8 +11979,7 @@ package body Sem_Ch3 is
(S : Node_Id; (S : Node_Id;
Related_Nod : Node_Id; Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty; Related_Id : Entity_Id := Empty;
Suffix : Character := ' ') Suffix : Character := ' ') return Entity_Id
return Entity_Id
is is
P : Node_Id; P : Node_Id;
Def_Id : Entity_Id; Def_Id : Entity_Id;
......
gcc/ada/sem_ch3.ads
...@@ -42,8 +42,7 @@ package Sem_Ch3 is ...@@ -42,8 +42,7 @@ package Sem_Ch3 is
function Access_Definition function Access_Definition
(Related_Nod : Node_Id; (Related_Nod : Node_Id;
N : Node_Id) N : Node_Id) return Entity_Id;
return Entity_Id;
-- An access definition defines a general access type for a formal -- An access definition defines a general access type for a formal
-- parameter. The procedure is called when processing formals, when -- parameter. The procedure is called when processing formals, when
-- the current scope is the subprogram. The Implicit type is attached -- the current scope is the subprogram. The Implicit type is attached
...@@ -131,8 +130,7 @@ package Sem_Ch3 is ...@@ -131,8 +130,7 @@ package Sem_Ch3 is
function Get_Discriminant_Value function Get_Discriminant_Value
(Discriminant : Entity_Id; (Discriminant : Entity_Id;
Typ_For_Constraint : Entity_Id; Typ_For_Constraint : Entity_Id;
Constraint : Elist_Id) Constraint : Elist_Id) return Node_Id;
return Node_Id;
-- ??? MORE DOCUMENTATION -- ??? MORE DOCUMENTATION
-- Given a discriminant somewhere in the Typ_For_Constraint tree -- Given a discriminant somewhere in the Typ_For_Constraint tree
-- and a Constraint, return the value of that discriminant. -- and a Constraint, return the value of that discriminant.
...@@ -195,8 +193,7 @@ package Sem_Ch3 is ...@@ -195,8 +193,7 @@ package Sem_Ch3 is
(S : Node_Id; (S : Node_Id;
Related_Nod : Node_Id; Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty; Related_Id : Entity_Id := Empty;
Suffix : Character := ' ') Suffix : Character := ' ') return Entity_Id;
return Entity_Id;
-- Process a subtype indication S and return corresponding entity. -- Process a subtype indication S and return corresponding entity.
-- Related_Nod is the node where the potential generated implicit types -- Related_Nod is the node where the potential generated implicit types
-- will be inserted. The Related_Id and Suffix parameters are used to -- will be inserted. The Related_Id and Suffix parameters are used to
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment