This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
committed: ada updates
- From: Arnaud Charlet <charlet at ACT-Europe dot FR>
- To: gcc-patches at gcc dot gnu dot org
- Date: Fri, 24 Oct 2003 15:04:59 +0200
- Subject: committed: ada updates
PR fixes and improvements, described in log below.
diff against Make-lang.in not included since huge and mechanical.
2003-10-24 Pascal Obry <obry@gnat.com>
* 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.
2003-10-24 Jose Ruiz <ruiz@act-europe.fr>
* 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.
2003-10-24 Vincent Celier <celier@gnat.com>
* 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
2003-10-24 Arnaud Charlet <charlet@act-europe.fr>
* 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.
2003-10-24 Robert Dewar <dewar@gnat.com>
* 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)
2003-10-24 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
--
Index: adadecode.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adadecode.c,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 adadecode.c
*** adadecode.c 24 Apr 2003 17:53:57 -0000 1.5
--- adadecode.c 24 Oct 2003 12:12:38 -0000
***************
*** 2,12 ****
* *
* GNAT COMPILER COMPONENTS *
* *
! * G N A T D E C O *
* *
* 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- *
--- 2,12 ----
* *
* GNAT COMPILER COMPONENTS *
* *
! * A D A D E C O D E *
* *
* C Implementation File *
* *
! * 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,49 ****
#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;
--- 42,53 ----
#include "adadecode.h"
static void add_verbose PARAMS ((const char *, 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;
*************** static void add_verbose (text, ada_name)
*** 65,71 ****
static int
has_prefix (name, prefix)
! char *name;
const char *prefix;
{
return strncmp (name, prefix, strlen (prefix)) == 0;
--- 69,75 ----
static int
has_prefix (name, prefix)
! const char *name;
const char *prefix;
{
return strncmp (name, prefix, strlen (prefix)) == 0;
*************** has_prefix (name, prefix)
*** 75,81 ****
static int
has_suffix (name, suffix)
! char *name;
const char *suffix;
{
int nlen = strlen (name);
--- 79,85 ----
static int
has_suffix (name, suffix)
! const char *name;
const char *suffix;
{
int nlen = strlen (name);
*************** has_suffix (name, suffix)
*** 84,89 ****
--- 88,105 ----
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
*************** __gnat_decode (coded_name, ada_name, ver
*** 142,157 ****
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"))
--- 158,171 ----
int in_task = 0;
int body_nested = 0;
/* Check for library level subprogram. */
! if (has_prefix (coded_name, "_ada_"))
{
! 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"))
*************** __gnat_decode (coded_name, ada_name, ver
*** 191,197 ****
while ((tktoken = (char *) strstr (ada_name, "TK__")) != NULL)
{
! strcpy (tktoken, tktoken + 2);
in_task = 1;
}
}
--- 205,211 ----
while ((tktoken = (char *) strstr (ada_name, "TK__")) != NULL)
{
! ostrcpy (tktoken, tktoken + 2);
in_task = 1;
}
}
*************** __gnat_decode (coded_name, ada_name, ver
*** 229,235 ****
if (ada_name[k] == '_' && ada_name[k+1] == '_')
{
ada_name[k] = '.';
! strcpy (ada_name + k + 1, ada_name + k + 2);
len = len - 1;
}
k++;
--- 243,249 ----
if (ada_name[k] == '_' && ada_name[k+1] == '_')
{
ada_name[k] = '.';
! ostrcpy (ada_name + k + 1, ada_name + k + 2);
len = len - 1;
}
k++;
*************** __gnat_decode (coded_name, ada_name, ver
*** 259,265 ****
if (codedlen > oplen)
/* We shrink the space. */
! strcpy (optoken, optoken + codedlen - oplen);
else if (oplen > codedlen)
{
/* We need more space. */
--- 273,279 ----
if (codedlen > oplen)
/* We shrink the space. */
! ostrcpy (optoken, optoken + codedlen - oplen);
else if (oplen > codedlen)
{
/* We need more space. */
*************** __gnat_decode (coded_name, ada_name, ver
*** 285,291 ****
}
/* If verbose mode is on, we add some information to the Ada name. */
! if (verbose)
{
if (overloaded)
add_verbose ("overloaded", ada_name);
--- 299,305 ----
}
/* If verbose mode is on, we add some information to the Ada name. */
! if (verbose)
{
if (overloaded)
add_verbose ("overloaded", ada_name);
Index: exp_disp.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_disp.adb,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 exp_disp.adb
*** exp_disp.adb 21 Oct 2003 13:41:59 -0000 1.5
--- exp_disp.adb 24 Oct 2003 12:12:38 -0000
*************** package body Exp_Disp is
*** 922,932 ****
-- Register_Tag (Dt_Ptr);
! -- Skip this if routine not available, or in No_Run_Time mode
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,
--- 922,931 ----
-- Register_Tag (Dt_Ptr);
! -- Skip this if routine not available
if RTE_Available (RE_Register_Tag)
and then Is_RTE (Generalized_Tag, RE_Tag)
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
Index: g-catiio.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-catiio.adb,v
retrieving revision 1.4
diff -u -c -3 -p -r1.4 g-catiio.adb
*** g-catiio.adb 21 Oct 2003 13:42:00 -0000 1.4
--- g-catiio.adb 24 Oct 2003 12:12:38 -0000
*************** package body GNAT.Calendar.Time_IO is
*** 44,50 ****
type Month_Name is
(January,
! Febuary,
March,
April,
May,
--- 44,50 ----
type Month_Name is
(January,
! February,
March,
April,
May,
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.17
diff -u -c -3 -p -r1.17 make.adb
*** make.adb 21 Oct 2003 13:42:09 -0000 1.17
--- make.adb 24 Oct 2003 12:12:39 -0000
*************** with Ada.Exceptions; use Ada.Exception
*** 28,33 ****
--- 28,34 ----
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;
*************** package body Make is
*** 178,183 ****
--- 179,209 ----
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.
*************** package body Make is
*** 3340,3345 ****
--- 3366,3512 ----
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,
*************** package body Make is
*** 3383,3395 ****
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.
! 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;
end if;
end;
--- 3550,3641 ----
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. 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
! 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;
*************** package body Make is
*** 5256,5261 ****
--- 5502,5509 ----
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);
*************** package body Make is
*** 5850,5855 ****
--- 6098,6165 ----
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 --
----------
*************** package body Make is
*** 6521,6526 ****
--- 6831,6837 ----
else
Add_File (Argv);
+ Mains.Add_Main (Argv);
end if;
end Scan_Make_Arg;
Index: Makefile.generic
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.generic,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 Makefile.generic
*** Makefile.generic 21 Oct 2003 13:41:53 -0000 1.1
--- Makefile.generic 24 Oct 2003 12:12:39 -0000
***************
*** 47,52 ****
--- 47,53 ----
# 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,61 ****
--- 57,63 ----
# 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)
*************** ifndef MAIN
*** 65,70 ****
--- 67,76 ----
MAIN=ada
endif
+ ifndef CC
+ CC=gcc
+ endif
+
ifndef ADA_SPEC
ADA_SPEC=.ads
endif
*************** ifndef AR_CMD
*** 100,109 ****
--- 106,123 ----
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
*************** vpath %$(AR_EXT) $(OBJ_DIR)
*** 120,125 ****
--- 134,140 ----
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++_%))
*************** clean: $(clean_deps) internal-clean
*** 131,136 ****
--- 146,152 ----
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++
*************** $(clean_deps): force
*** 140,145 ****
--- 156,164 ----
$(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
*************** DEP_FILES := $(OBJ_FILES:$(OBJ_EXT)=.d)
*** 238,243 ****
--- 257,263 ----
ifeq ($(strip $(OBJECTS)),)
internal-compile:
+ internal-archive-objects:
else
internal-compile: lib$(PROJECT_BASE)$(AR_EXT)
*************** internal-compile: lib$(PROJECT_BASE)$(AR
*** 245,251 ****
lib$(PROJECT_BASE)$(AR_EXT): $(OBJECTS)
@echo creating archive file for $(PROJECT_BASE)
cd $(OBJ_DIR); $(AR_CMD) $@ $(strip $(OBJECTS))
! -ranlib $(OBJ_DIR)/$@
endif
# Linking rules
--- 265,277 ----
lib$(PROJECT_BASE)$(AR_EXT): $(OBJECTS)
@echo creating archive file for $(PROJECT_BASE)
cd $(OBJ_DIR); $(AR_CMD) $@ $(strip $(OBJECTS))
! -$(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
*************** endif
*** 260,268 ****
ifeq ($(strip $(filter-out c c++,$(LANGUAGES))),)
# link with C/C++
! link: $(EXEC_DIR)/$(EXEC)
$(EXEC_DIR)/$(EXEC): $(OBJ_FILES)
! $(LINKER) $(OBJ_FILES) -o $(EXEC_DIR)/$(EXEC) $(LDFLAGS)
internal-build: internal-compile link
--- 286,309 ----
ifeq ($(strip $(filter-out c c++,$(LANGUAGES))),)
# link with C/C++
! 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)
! @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
*************** ifeq ($(strip $(filter-out c c++ ada,$(L
*** 272,282 ****
ifeq ($(MAIN),ada)
# Ada main
! link: $(LINKER) force
$(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(LARGS) $(LDFLAGS)
! internal-build: $(LINKER) force
@echo $(GNATMAKE) -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) -P$(PROJECT_FILE) $(EXEC_RULE) $(ADA_SOURCES) $(ADAFLAGS) \
-largs $(LARGS) $(LDFLAGS)
--- 313,323 ----
ifeq ($(MAIN),ada)
# Ada main
! link: $(LINKER) archive-objects force
$(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(LARGS) $(LDFLAGS)
! 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)
*************** else
*** 288,298 ****
# close enough to our needs, and the usual -n gnatbind switch and --LINK=
# gnatlink switch.
! link: $(LINKER) force
$(GNATMAKE) $(EXEC_RULE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) \
-bargs -n -largs $(LARGS) $(LDFLAGS)
! internal-build: $(LINKER) force
@echo $(GNATMAKE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) $(EXEC_RULE) -z \
-P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
--- 329,339 ----
# close enough to our needs, and the usual -n gnatbind switch and --LINK=
# gnatlink switch.
! link: $(LINKER) archive-objects force
$(GNATMAKE) $(EXEC_RULE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) \
-bargs -n -largs $(LARGS) $(LDFLAGS)
! 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) \
*************** internal-c : $(C_OBJECTS)
*** 385,391 ****
# 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++
internal-clean:
@echo $(RM) $(OBJ_DIR)/*$(OBJ_EXT)
--- 426,432 ----
# Compile all C++ files in the project
internal-c++ : $(CXX_OBJECTS)
! .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)
Index: prj-env.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-env.adb,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 prj-env.adb
*** prj-env.adb 21 Oct 2003 13:42:12 -0000 1.10
--- prj-env.adb 24 Oct 2003 12:12:39 -0000
*************** package body Prj.Env is
*** 1060,1066 ****
function File_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id;
! Main_Project_Only : Boolean := True)
return String
is
The_Project : Project_Id := Project;
--- 1060,1067 ----
function File_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id;
! Main_Project_Only : Boolean := True;
! Full_Path : Boolean := False)
return String
is
The_Project : Project_Id := Project;
*************** package body Prj.Env is
*** 1151,1157 ****
Write_Line (" OK");
end if;
! return Get_Name_String (Current_Name);
-- If it has the name of the extended body name,
-- return the extended body name
--- 1152,1164 ----
Write_Line (" OK");
end if;
! 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
*************** package body Prj.Env is
*** 1161,1167 ****
Write_Line (" OK");
end if;
! return Extended_Body_Name;
else
if Current_Verbosity = High then
--- 1168,1180 ----
Write_Line (" OK");
end if;
! 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
*************** package body Prj.Env is
*** 1202,1208 ****
Write_Line (" OK");
end if;
! return Get_Name_String (Current_Name);
-- If it has the same name as the extended spec name,
-- return the extended spec name.
--- 1215,1228 ----
Write_Line (" OK");
end if;
!
! 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.
*************** package body Prj.Env is
*** 1212,1218 ****
Write_Line (" OK");
end if;
! return Extended_Spec_Name;
else
if Current_Verbosity = High then
--- 1232,1244 ----
Write_Line (" OK");
end if;
! 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
*************** package body Prj.Env is
*** 1700,1705 ****
--- 1726,1826 ----
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 --
Index: prj-env.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-env.ads,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 prj-env.ads
*** prj-env.ads 21 Oct 2003 13:42:12 -0000 1.8
--- prj-env.ads 24 Oct 2003 12:12:39 -0000
*************** package Prj.Env is
*** 101,116 ****
function File_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id;
! Main_Project_Only : Boolean := True)
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.
-- 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.
procedure Get_Reference
(Source_File_Name : String;
--- 101,128 ----
function File_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id;
! 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 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;
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.22
diff -u -c -3 -p -r1.22 sem_ch12.adb
*** sem_ch12.adb 22 Oct 2003 09:28:08 -0000 1.22
--- sem_ch12.adb 24 Oct 2003 12:12:39 -0000
*************** package body Sem_Ch12 is
*** 7688,7694 ****
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.
--- 7688,7693 ----
*************** package body Sem_Ch12 is
*** 7697,7715 ****
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))
then
Ancestor := Generic_Parent_Type (Decl);
exit;
--- 7696,7714 ----
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))
then
Ancestor := Generic_Parent_Type (Decl);
exit;
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.19
diff -u -c -3 -p -r1.19 sem_ch3.adb
*** sem_ch3.adb 22 Oct 2003 09:28:08 -0000 1.19
--- sem_ch3.adb 24 Oct 2003 12:12:39 -0000
*************** package body Sem_Ch3 is
*** 169,176 ****
Derived_Base : Entity_Id;
Is_Tagged : Boolean;
Inherit_Discr : Boolean;
! 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
--- 169,175 ----
Derived_Base : Entity_Id;
Is_Tagged : Boolean;
Inherit_Discr : Boolean;
! 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
*************** package body Sem_Ch3 is
*** 217,224 ****
function Build_Discriminant_Constraints
(T : Entity_Id;
Def : Node_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
--- 216,222 ----
function Build_Discriminant_Constraints
(T : Entity_Id;
Def : Node_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
*************** package body Sem_Ch3 is
*** 256,263 ****
function Build_Scalar_Bound
(Bound : Node_Id;
Par_T : Entity_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
--- 254,260 ----
function Build_Scalar_Bound
(Bound : Node_Id;
Par_T : Entity_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
*************** package body Sem_Ch3 is
*** 356,363 ****
Constrained_Typ : Entity_Id;
Related_Node : Node_Id;
Typ : 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
--- 353,359 ----
Constrained_Typ : Entity_Id;
Related_Node : Node_Id;
Typ : 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
*************** package body Sem_Ch3 is
*** 419,426 ****
(Prot_Subt : Entity_Id;
Corr_Rec : Entity_Id;
Related_Nod : Node_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.
--- 415,421 ----
(Prot_Subt : Entity_Id;
Corr_Rec : Entity_Id;
Related_Nod : Node_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.
*************** package body Sem_Ch3 is
*** 521,528 ****
function Expand_To_Stored_Constraint
(Typ : Entity_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
--- 516,522 ----
function Expand_To_Stored_Constraint
(Typ : Entity_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
*************** package body Sem_Ch3 is
*** 530,537 ****
function Find_Type_Of_Object
(Obj_Def : Node_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
--- 524,530 ----
function Find_Type_Of_Object
(Obj_Def : Node_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
*************** package body Sem_Ch3 is
*** 546,553 ****
function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind;
! 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).
--- 539,545 ----
function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind;
! 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).
*************** package body Sem_Ch3 is
*** 670,677 ****
function Access_Definition
(Related_Nod : Node_Id;
! N : Node_Id)
! return Entity_Id
is
Anon_Type : constant Entity_Id :=
Create_Itype (E_Anonymous_Access_Type, Related_Nod,
--- 662,668 ----
function Access_Definition
(Related_Nod : Node_Id;
! N : Node_Id) return Entity_Id
is
Anon_Type : constant Entity_Id :=
Create_Itype (E_Anonymous_Access_Type, Related_Nod,
*************** package body Sem_Ch3 is
*** 727,732 ****
--- 718,724 ----
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));
*************** package body Sem_Ch3 is
*** 739,744 ****
--- 731,737 ----
Error_Msg_N
("expect type in function specification", Subtype_Mark (T_Def));
end if;
+
else
Set_Etype (Desig_Type, Standard_Void_Type);
end if;
*************** package body Sem_Ch3 is
*** 5322,5329 ****
function Build_Discriminant_Constraints
(T : Entity_Id;
Def : Node_Id;
! Derived_Def : Boolean := False)
! return Elist_Id
is
C : constant Node_Id := Constraint (Def);
Nb_Discr : constant Nat := Number_Discriminants (T);
--- 5315,5321 ----
function Build_Discriminant_Constraints
(T : Entity_Id;
Def : Node_Id;
! Derived_Def : Boolean := False) return Elist_Id
is
C : constant Node_Id := Constraint (Def);
Nb_Discr : constant Nat := Number_Discriminants (T);
*************** package body Sem_Ch3 is
*** 5734,5741 ****
function Build_Scalar_Bound
(Bound : Node_Id;
Par_T : Entity_Id;
! Der_T : Entity_Id)
! return Node_Id
is
New_Bound : Entity_Id;
--- 5726,5732 ----
function Build_Scalar_Bound
(Bound : Node_Id;
Par_T : Entity_Id;
! Der_T : Entity_Id) return Node_Id
is
New_Bound : Entity_Id;
*************** package body Sem_Ch3 is
*** 6918,6943 ****
Constrained_Typ : Entity_Id;
Related_Node : Node_Id;
Typ : 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;
-- 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;
-- Ditto for record components.
function Build_Constrained_Access_Type
! (Old_Type : Entity_Id)
! return Entity_Id;
-- Ditto for access types. Makes use of previous two functions, to
-- constrain designated type.
--- 6909,6930 ----
Constrained_Typ : Entity_Id;
Related_Node : Node_Id;
Typ : 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;
-- 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;
-- Ditto for record components.
function Build_Constrained_Access_Type
! (Old_Type : Entity_Id) return Entity_Id;
-- Ditto for access types. Makes use of previous two functions, to
-- constrain designated type.
*************** package body Sem_Ch3 is
*** 6956,6963 ****
-----------------------------------
function Build_Constrained_Access_Type
! (Old_Type : Entity_Id)
! return Entity_Id
is
Desig_Type : constant Entity_Id := Designated_Type (Old_Type);
Itype : Entity_Id;
--- 6943,6949 ----
-----------------------------------
function Build_Constrained_Access_Type
! (Old_Type : Entity_Id) return Entity_Id
is
Desig_Type : constant Entity_Id := Designated_Type (Old_Type);
Itype : Entity_Id;
*************** package body Sem_Ch3 is
*** 7043,7050 ****
----------------------------------
function Build_Constrained_Array_Type
! (Old_Type : Entity_Id)
! return Entity_Id
is
Lo_Expr : Node_Id;
Hi_Expr : Node_Id;
--- 7029,7035 ----
----------------------------------
function Build_Constrained_Array_Type
! (Old_Type : Entity_Id) return Entity_Id
is
Lo_Expr : Node_Id;
Hi_Expr : Node_Id;
*************** package body Sem_Ch3 is
*** 7104,7111 ****
------------------------------------------
function Build_Constrained_Discriminated_Type
! (Old_Type : Entity_Id)
! return Entity_Id
is
Expr : Node_Id;
Constr_List : List_Id;
--- 7089,7095 ----
------------------------------------------
function Build_Constrained_Discriminated_Type
! (Old_Type : Entity_Id) return Entity_Id
is
Expr : Node_Id;
Constr_List : List_Id;
*************** package body Sem_Ch3 is
*** 7374,7381 ****
(Prot_Subt : Entity_Id;
Corr_Rec : Entity_Id;
Related_Nod : Node_Id;
! Related_Id : Entity_Id)
! return Entity_Id
is
T_Sub : constant Entity_Id
:= Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V');
--- 7358,7364 ----
(Prot_Subt : Entity_Id;
Corr_Rec : Entity_Id;
Related_Nod : Node_Id;
! Related_Id : Entity_Id) return Entity_Id
is
T_Sub : constant Entity_Id
:= Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V');
*************** package body Sem_Ch3 is
*** 9249,9256 ****
function Expand_To_Stored_Constraint
(Typ : Entity_Id;
! Constraint : Elist_Id)
! return Elist_Id
is
Explicitly_Discriminated_Type : Entity_Id;
Expansion : Elist_Id;
--- 9232,9238 ----
function Expand_To_Stored_Constraint
(Typ : Entity_Id;
! Constraint : Elist_Id) return Elist_Id
is
Explicitly_Discriminated_Type : Entity_Id;
Expansion : Elist_Id;
*************** package body Sem_Ch3 is
*** 9517,9524 ****
function Find_Type_Of_Object
(Obj_Def : Node_Id;
! Related_Nod : Node_Id)
! return Entity_Id
is
Def_Kind : constant Node_Kind := Nkind (Obj_Def);
P : constant Node_Id := Parent (Obj_Def);
--- 9499,9505 ----
function Find_Type_Of_Object
(Obj_Def : Node_Id;
! Related_Nod : Node_Id) return Entity_Id
is
Def_Kind : constant Node_Kind := Nkind (Obj_Def);
P : constant Node_Id := Parent (Obj_Def);
*************** package body Sem_Ch3 is
*** 9810,9823 ****
function Get_Discriminant_Value
(Discriminant : Entity_Id;
Typ_For_Constraint : Entity_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;
-- This is the routine that performs the recursive search of levels
-- as described above.
--- 9791,9802 ----
function Get_Discriminant_Value
(Discriminant : Entity_Id;
Typ_For_Constraint : Entity_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;
-- This is the routine that performs the recursive search of levels
-- as described above.
*************** package body Sem_Ch3 is
*** 9828,9835 ****
function Search_Derivation_Levels
(Ti : Entity_Id;
Discrim_Values : Elist_Id;
! Stored_Discrim_Values : Boolean)
! return Node_Or_Entity_Id
is
Assoc : Elmt_Id;
Disc : Entity_Id;
--- 9807,9813 ----
function Search_Derivation_Levels
(Ti : Entity_Id;
Discrim_Values : Elist_Id;
! Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id
is
Assoc : Elmt_Id;
Disc : Entity_Id;
*************** package body Sem_Ch3 is
*** 10051,10058 ****
Derived_Base : Entity_Id;
Is_Tagged : Boolean;
Inherit_Discr : Boolean;
! Discs : Elist_Id)
! return Elist_Id
is
Assoc_List : constant Elist_Id := New_Elmt_List;
--- 10029,10035 ----
Derived_Base : Entity_Id;
Is_Tagged : Boolean;
Inherit_Discr : Boolean;
! Discs : Elist_Id) return Elist_Id
is
Assoc_List : constant Elist_Id := New_Elmt_List;
*************** package body Sem_Ch3 is
*** 10288,10295 ****
function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind;
! Constraint_Kind : Node_Kind)
! return Boolean
is
begin
case T_Kind is
--- 10265,10271 ----
function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind;
! Constraint_Kind : Node_Kind) return Boolean
is
begin
case T_Kind is
*************** package body Sem_Ch3 is
*** 12003,12010 ****
(S : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
! Suffix : Character := ' ')
! return Entity_Id
is
P : Node_Id;
Def_Id : Entity_Id;
--- 11979,11985 ----
(S : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
! Suffix : Character := ' ') return Entity_Id
is
P : Node_Id;
Def_Id : Entity_Id;
Index: sem_ch3.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.ads,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 sem_ch3.ads
*** sem_ch3.ads 21 Oct 2003 13:42:19 -0000 1.7
--- sem_ch3.ads 24 Oct 2003 12:12:39 -0000
*************** package Sem_Ch3 is
*** 42,49 ****
function Access_Definition
(Related_Nod : Node_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
--- 42,48 ----
function Access_Definition
(Related_Nod : Node_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
*************** package Sem_Ch3 is
*** 129,138 ****
-- private type.
function Get_Discriminant_Value
! (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.
--- 128,136 ----
-- private type.
function Get_Discriminant_Value
! (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.
*************** package Sem_Ch3 is
*** 195,202 ****
(S : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
! 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
--- 193,199 ----
(S : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
! 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
Index: adadecode.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adadecode.h,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 adadecode.h
*** adadecode.h 24 Oct 2003 02:28:37 -0000 1.5
--- adadecode.h 24 Oct 2003 12:12:39 -0000
***************
*** 2,12 ****
* *
* GNAT COMPILER COMPONENTS *
* *
! * G N A T D E C O *
* *
* 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- *
--- 2,12 ----
* *
* GNAT COMPILER COMPONENTS *
* *
! * A D A D E C O D E *
* *
* C Header File *
* *
! * 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- *
Index: atree.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.h,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 atree.h
*** atree.h 24 Oct 2003 02:28:37 -0000 1.6
--- atree.h 24 Oct 2003 12:12:39 -0000
***************
*** 6,12 ****
* *
* C Header File *
* *
! * 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- *
--- 6,12 ----
* *
* C Header File *
* *
! * 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- *
*************** struct Extended
*** 235,241 ****
Int field8;
Int field9;
Int field10;
! union
{
Int field11;
struct Flag_Word3 fw3;
--- 235,241 ----
Int field8;
Int field9;
Int field10;
! union
{
Int field11;
struct Flag_Word3 fw3;
Index: elists.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/elists.h,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 elists.h
*** elists.h 24 Oct 2003 02:28:37 -0000 1.6
--- elists.h 24 Oct 2003 12:12:39 -0000
***************
*** 6,12 ****
* *
* C Header File *
* *
! * 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- *
--- 6,12 ----
* *
* C Header File *
* *
! * 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- *
Index: nlists.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/nlists.h,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 nlists.h
*** nlists.h 24 Oct 2003 02:28:37 -0000 1.6
--- nlists.h 24 Oct 2003 12:12:39 -0000
***************
*** 6,12 ****
* *
* C Header File *
* *
! * 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- *
--- 6,12 ----
* *
* C Header File *
* *
! * 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- *
Index: raise.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/raise.h,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 raise.h
*** raise.h 24 Oct 2003 02:28:37 -0000 1.6
--- raise.h 24 Oct 2003 12:12:39 -0000
***************
*** 6,12 ****
* *
* C Header File *
* *
! * Copyright (C) 1992-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- *
--- 6,12 ----
* *
* C Header File *
* *
! * 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- *