This is the mail archive of the
gcc-bugs@gcc.gnu.org
mailing list for the GCC project.
committed: Ada updates
- From: Arnaud Charlet <charlet at ACT-Europe dot FR>
- To: gcc-bugs at gcc dot gnu dot org
- Date: Mon, 10 Nov 2003 18:31:18 +0100
- Subject: committed: Ada updates
Tested on x86-linux
--
2003-11-10 Ed Falis <falis@gnat.com>
* 5ytiitho.adb: (procStartHookAdd): Definition and call deleted
* 5zinit.adb: (Install_Handler): Moved back to spec
(Install_Signal_Handlers): Deleted
* 5zthrini.adb: Added context clause for System.Storage_Elements
(Register): Only handles creation of taskVar; initialization moved to
Thread_Body_Enter.
(Reset_TSD): Deleted; replaced by Thread_Body_Enter
Added declaration of environment task secondary stack and
initialization.
* s-thread.adb: Implement bodies for thread body processing
* s-thread.ads:
Added comment identifying supported targets for pragma Thread_Body.
2003-11-10 Pascal Obry <obry@gnat.com>
* adaint.c (_gnat_stat) [WIN32]: Check if name is not bigger than
GNAT_MAX_PATH_LEN.
* s-fileio.adb:
(Open): Properly check for string length before copying into the buffer.
Raises Name_Error if buffer is too small. Note that this was a potential
buffer overflow.
2003-11-10 Romain Berrendonner <berrendo@act-europe.fr>
* bindgen.adb, comperr.adb: Code clean ups.
* gnatvsn.ads, gnatvsn.adb (Get_Gnat_Version_Type): New function.
2003-11-10 Sergey Rybin <rybin@act-europe.fr>
* gnat1drv.adb: Add call to Sem_Elim.Initialize.
2003-11-10 Vincent Celier <celier@gnat.com>
* gprcmd.adb:
(Gprcmd): Add new command "prefix" to get the prefix of the GNAT
installation.
* make.adb (Scan_Make_Arg): Transmit -nostdlib to the compiler
* prj.adb: (Project_Empty): Add new boolean component Virtual
* prj.ads: (Virtual_Prefix): New constant string
(Project_Data): New boolean component Virtual
* prj-nmsc.adb (Language_Independent_Check): Adjust error message when
a library project is extended by a virtual extending project.
* prj-part.adb:
Modifications throughout to implement extending-all project, including:
(Virtual_Hash, Processed_Hash): New hash tables
(Create_Virtual_Extending_Project): New procedure
(Look_For_Virtual_Projects_For): New procedure
* prj-proc.adb:
(Process): After checking the projects, if main project is an
extending-all project, set the object directory of all virtual extending
project to the object directory of the main project.
Adjust error message when a virtual extending project has the same
object directory as an project being extended.
(Recursive_Process): If name starts with the virtual prefix, set Virtual
to True in the project data.
* prj-tree.adb:
(Default_Project_Node): Add new boolean component Extending_All
(Is_Extending_All): New function
(Set_Is_Extending_All): New procedure
* prj-tree.ads: (Is_Extending_All): New function
(Set_Is_Extending_All): New procedure
(Project_Node_Record): New boolean component Extending_All
* switch-c.adb: (Scan_Front_End_Switches): Process -nostdlib
* vms_data.ads:
Add qualifier /NOSTD_LIBRARIES (-nostdlib) for the compiler
* bld.adb (Recursive_Process): If MAKE_ROOT is not defined, call
"gprcmd prefix" to define it.
2003-11-10 Thomas Quinot <quinot@act-europe.fr>
* einfo.ads: Fix a typo and remove an extraneous word in comments.
* lib-load.adb:
(Create_Dummy_Package_Unit): Set the scope of the entity for the
created dummy package to Standard_Standard, not to itself, to
defend other parts of the front-end against encoutering a cycle in
the scope chain.
* sem_ch10.adb:
(Analyze_With_Clause): When setting the entities for the successive
N_Expanded_Names that constitute the name of a child unit, do not
attempt to go further than Standard_Standard in the chain of scopes.
This case arises from the placeholder units created by
Create_Dummy_Package_Unit in the case of a with_clause for a
nonexistent child unit.
2003-11-10 Ed Schonberg <schonberg@gnat.com>
* exp_ch6.adb:
(Expand_Thread_Body): Place subprogram on scope stack, so that new
declarations are given the proper scope.
* sem_ch13.adb:
(Check_Expr_Constants): Reject an expression that contains a constant
created during expansion, and that appears after the object to which
the address clause applies.
* sem_ch5.adb (Check_Controlled_Array_Attribute): Subsidiary of
Analyze_Iteration_Scheme, to rewrite a loop parameter specification
that uses 'Range of a function call with controlled components, so
that the function result can be finalized before starting the loop.
* sem_ch8.adb:
(Find_Selected_Component): Improve error message when prefix is
an implicit dereference of an incomplete type.
2003-11-10 Robert Dewar <dewar@gnat.com>
* opt.ads: New Print_Standard flag for -gnatS switch
* sem_ch13.adb: Remove some additional checks for unaligned arrays
* cstand.adb (Create_Standard): Print out package standard if -gnatS
switch set
* debug.adb: Update doc for -gnatds to discuss relationship with new
-gnatS flag
* sinfo.adb: Add new field Entity_Or_Associated_Node
* sinfo.ads: Add new field Entity_Or_Associated_Node
Update documentation for Associated_Node and Entity fields to clarify
relationship and usage.
* sprint.adb:
(Write_Id): Properly process Associated_Node field in generic template
* switch-c.adb:
Recognize new -gnatS switch for printing package Standard
This replaces gnatpsta
* usage.adb:
Add line for new -gnatS switch for printing package Standard
This replaces gnatpsta
--
Index: 5ytiitho.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5ytiitho.adb,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 5ytiitho.adb
*** 5ytiitho.adb 21 Oct 2003 13:41:52 -0000 1.1
--- 5ytiitho.adb 10 Nov 2003 16:49:42 -0000
***************
*** 35,44 ****
-- This is the VxWorks AE 653 version of this procedure
separate (System.Threads.Initialization)
-
procedure Initialize_Task_Hooks is
! -- When defining the following routines for export in an AE 1.1
-- simulation of AE653, Interfaces.C.int may be used for the
-- parameters of FUNCPTR.
type FUNCPTR is access function (T : OSI.Thread_Id) return OSI.STATUS;
--- 35,43 ----
-- This is the VxWorks AE 653 version of this procedure
separate (System.Threads.Initialization)
procedure Initialize_Task_Hooks is
! -- When defining the following routine for export in an AE 1.1
-- simulation of AE653, Interfaces.C.int may be used for the
-- parameters of FUNCPTR.
type FUNCPTR is access function (T : OSI.Thread_Id) return OSI.STATUS;
*************** procedure Initialize_Task_Hooks is
*** 51,66 ****
pragma Import (C, procCreateHookAdd, "procCreateHookAdd");
-- Registers task registration routine for AE653
- procedure procStartHookAdd (StartHookFunction : FUNCPTR);
- pragma Import (C, procStartHookAdd, "procStartHookAdd");
- -- Registers task restart routine for AE653
-
- Result : OSI.STATUS;
begin
! -- Register the exported routines with the vThreads ARINC API
procCreateHookAdd (Register'Access);
- procStartHookAdd (Reset_TSD'Access);
- -- Register the environment task
- Result := Register (OSI.taskIdSelf);
- pragma Assert (Result /= -1);
end Initialize_Task_Hooks;
--- 50,56 ----
pragma Import (C, procCreateHookAdd, "procCreateHookAdd");
-- Registers task registration routine for AE653
begin
! -- Register the exported routine with the vThreads ARINC API
procCreateHookAdd (Register'Access);
end Initialize_Task_Hooks;
Index: 5zinit.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zinit.adb,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 5zinit.adb
*** 5zinit.adb 21 Oct 2003 13:41:52 -0000 1.1
--- 5zinit.adb 10 Nov 2003 16:49:42 -0000
*************** package body System.Init is
*** 104,114 ****
-- Common procedure that is executed when a SIGFPE, SIGILL,
-- SIGSEGV, or SIGBUS is captured.
- procedure Install_Handler;
- pragma Export (C, Install_Handler, "__gnat_install_handler");
- -- Install handler for the synchronous signals. The C profile
- -- here is what is expected by the binder-generated main.
-
------------------------
-- GNAT_Error_Handler --
------------------------
--- 104,109 ----
*************** package body System.Init is
*** 237,252 ****
Gl_Zero_Cost_Exceptions := Zero_Cost_Exceptions;
end if;
end Set_Globals;
-
- -----------------------------
- -- Install_Signal_Handlers --
- -----------------------------
-
- function Install_Signal_Handlers return Interfaces.C.int is
- begin
- Install_Handler;
- return 0;
- end Install_Signal_Handlers;
---------------------
-- Install_Handler --
--- 232,237 ----
Index: 5zthrini.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zthrini.adb,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 5zthrini.adb
*** 5zthrini.adb 21 Oct 2003 13:41:53 -0000 1.1
--- 5zthrini.adb 10 Nov 2003 16:49:42 -0000
***************
*** 35,40 ****
--- 35,41 ----
-- the task hook libraries should be included in the VxWorks kernel.
with System.Secondary_Stack;
+ with System.Storage_Elements;
with Interfaces.C;
with Unchecked_Conversion;
*************** package body System.Threads.Initializati
*** 64,75 ****
--------------
function Register (T : OSI.Thread_Id) return OSI.STATUS is
- TSD : ATSD_Access := new ATSD;
Result : OSI.STATUS;
begin
-- It cannot be assumed that the caller of this routine has a ATSD;
-- so neither this procedure nor the procedures that it calls should
! -- raise or handle exceptions, or make use of a secondary stack.
if OSI.taskIdVerify (T) = OSI.ERROR
or else OSI.taskVarGet (T, Current_ATSD'Access) /= OSI.ERROR
--- 65,80 ----
--------------
function Register (T : OSI.Thread_Id) return OSI.STATUS is
Result : OSI.STATUS;
begin
-- It cannot be assumed that the caller of this routine has a ATSD;
-- so neither this procedure nor the procedures that it calls should
! -- raise or handle exceptions, or make use of a secondary stack.
!
! -- This routine is only necessary because taskVarAdd cannot be
! -- executed once an AE653 partition has entered normal mode
! -- (depending on configRecord.c, allocation could be disabled).
! -- Otherwise, everything could have been done in Thread_Body_Enter.
if OSI.taskIdVerify (T) = OSI.ERROR
or else OSI.taskVarGet (T, Current_ATSD'Access) /= OSI.ERROR
*************** package body System.Threads.Initializati
*** 78,113 ****
end if;
Result := OSI.taskVarAdd (T, Current_ATSD'Access);
! pragma Assert (Result /= -1);
! Result := OSI.taskVarSet (T, Current_ATSD'Access, TSD.all'Address);
! pragma Assert (Result /= -1);
! TSD.Sec_Stack_Addr := SSS.SS_Create;
! SSS.SS_Init (TSD.Sec_Stack_Addr);
return Result;
end Register;
! ---------------
! -- Reset_TSD --
! ---------------
!
! function Reset_TSD (T : OSI.Thread_Id) return OSI.STATUS is
! TSD_Ptr : int;
! function To_Address is new Unchecked_Conversion
! (Interfaces.C.int, ATSD_Access);
! begin
! TSD_Ptr := OSI.taskVarGet (T, Current_ATSD'Access);
! pragma Assert (TSD_Ptr /= OSI.ERROR);
! -- Just reset the secondary stack pointer. The implementation here
! -- assumes that the fixed secondary stack implementation is used.
! -- If not, there will be a memory leak (along with allocation, which
! -- is prohibited for ARINC processes once the system enters "normal"
! -- mode).
!
! SSS.SS_Init (To_Address (TSD_Ptr).Sec_Stack_Addr);
! return OSI.OK;
! end Reset_TSD;
begin
Initialize_Task_Hooks;
end System.Threads.Initialization;
--- 83,116 ----
end if;
Result := OSI.taskVarAdd (T, Current_ATSD'Access);
! pragma Assert (Result /= OSI.ERROR);
!
return Result;
end Register;
! subtype Default_Sec_Stack is
! System.Storage_Elements.Storage_Array
! (1 .. SSS.Default_Secondary_Stack_Size);
!
! Main_Sec_Stack : aliased Default_Sec_Stack;
! -- Secondary stack for environment task
!
! Main_ATSD : aliased ATSD;
!
! -- TSD for environment task
begin
Initialize_Task_Hooks;
+
+ -- Register the environment task
+ declare
+ Result : Interfaces.C.int := Register (OSI.taskIdSelf);
+ pragma Assert (Result /= OSI.ERROR);
+ begin
+ Thread_Body_Enter
+ (Main_Sec_Stack'Address,
+ Main_Sec_Stack'Size / System.Storage_Unit,
+ Main_ATSD'Address);
+ end;
end System.Threads.Initialization;
Index: adaint.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adaint.c,v
retrieving revision 1.21
diff -u -c -3 -p -r1.21 adaint.c
*** adaint.c 4 Nov 2003 12:51:45 -0000 1.21
--- adaint.c 10 Nov 2003 16:49:42 -0000
*************** __gnat_stat (char *name, struct stat *st
*** 1339,1345 ****
terminated by a directory separator except if just after a drive name. */
int name_len = strlen (name);
char last_char = name[name_len - 1];
! char win32_name[4096];
strcpy (win32_name, name);
--- 1339,1348 ----
terminated by a directory separator except if just after a drive name. */
int name_len = strlen (name);
char last_char = name[name_len - 1];
! char win32_name[GNAT_MAX_PATH_LEN + 2];
!
! if (name_len > GNAT_MAX_PATH_LEN)
! return -1;
strcpy (win32_name, name);
Index: bindgen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bindgen.adb,v
retrieving revision 1.14
diff -u -c -3 -p -r1.14 bindgen.adb
*** bindgen.adb 21 Oct 2003 13:41:58 -0000 1.14
--- bindgen.adb 10 Nov 2003 16:49:43 -0000
*************** package body Bindgen is
*** 1894,1902 ****
---------------------
procedure Gen_Output_File (Filename : String) is
! Public_Version : constant Boolean := Gnat_Version_Type = "PUBLIC ";
! -- Set true if this is the public version of GNAT
!
begin
-- Acquire settings for Interrupt_State pragmas
--- 1894,1900 ----
---------------------
procedure Gen_Output_File (Filename : String) is
! Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
begin
-- Acquire settings for Interrupt_State pragmas
*************** package body Bindgen is
*** 1929,1935 ****
-- Get the time stamp of the former bind for public version warning
! if Public_Version then
Record_Time_From_Last_Bind;
end if;
--- 1927,1933 ----
-- Get the time stamp of the former bind for public version warning
! if Is_Public_Version then
Record_Time_From_Last_Bind;
end if;
*************** package body Bindgen is
*** 1944,1950 ****
-- Periodically issue a warning when the public version is used on
-- big projects
! if Public_Version then
Public_Version_Warning;
end if;
end Gen_Output_File;
--- 1942,1948 ----
-- Periodically issue a warning when the public version is used on
-- big projects
! if Is_Public_Version then
Public_Version_Warning;
end if;
end Gen_Output_File;
Index: bld.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bld.adb,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 bld.adb
*** bld.adb 21 Oct 2003 13:41:58 -0000 1.1
--- bld.adb 10 Nov 2003 16:49:43 -0000
*************** package body Bld is
*** 2595,2600 ****
--- 2595,2619 ----
-- Include some utility functions and saved all reserved
-- env. vars. by including Makefile.prolog.
+ New_Line;
+
+ -- First, if MAKE_ROOT is not defined, try to get GNAT prefix
+
+ Put (" ifeq ($(");
+ Put (MAKE_ROOT);
+ Put ("),)");
+ New_Line;
+
+ Put (" MAKE_ROOT=$(shell gprcmd prefix)");
+ New_Line;
+
+ Put (" endif");
+ New_Line;
+
+ New_Line;
+
+ -- If MAKE_ROOT is still not defined, then fail
+
Put (" ifeq ($(");
Put (MAKE_ROOT);
Put ("),)");
Index: comperr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/comperr.adb,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 comperr.adb
*** comperr.adb 21 Oct 2003 13:41:58 -0000 1.9
--- comperr.adb 10 Nov 2003 16:49:43 -0000
*************** package body Comperr is
*** 80,91 ****
-- the FSF version of GNAT, but there are specializations for
-- the GNATPRO and Public releases by Ada Core Technologies.
- Public_Version : constant Boolean := Gnat_Version_Type = "PUBLIC ";
- -- Set True for the public version of GNAT
-
- GNATPRO_Version : constant Boolean := Gnat_Version_Type = "GNATPRO";
- -- Set True for the GNATPRO version of GNAT
-
procedure End_Line;
-- Add blanks up to column 76, and then a final vertical bar
--- 80,85 ----
*************** package body Comperr is
*** 99,104 ****
--- 93,101 ----
Write_Eol;
end End_Line;
+ Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
+ Is_FSF_Version : constant Boolean := Get_Gnat_Build_Type = FSF;
+
-- Start of processing for Compiler_Abort
begin
*************** package body Comperr is
*** 264,270 ****
-- Otherwise we use the standard fixed text
else
! if Public_Version or GNATPRO_Version then
Write_Str
("| Please submit bug report by email " &
"to report@gnat.com.");
--- 261,273 ----
-- Otherwise we use the standard fixed text
else
! if Is_FSF_Version then
! Write_Str
! ("| Please submit a bug report; see" &
! " http://gcc.gnu.org/bugs.html.";);
! End_Line;
!
! else
Write_Str
("| Please submit bug report by email " &
"to report@gnat.com.");
*************** package body Comperr is
*** 274,288 ****
("| Use a subject line meaningful to you" &
" and us to track the bug.");
End_Line;
-
- else
- Write_Str
- ("| Please submit a bug report; see" &
- " http://gcc.gnu.org/bugs.html.";);
- End_Line;
end if;
! if GNATPRO_Version then
Write_Str
("| (include your customer number #nnn " &
"in the subject line).");
--- 277,285 ----
("| Use a subject line meaningful to you" &
" and us to track the bug.");
End_Line;
end if;
! if not (Is_Public_Version and Is_FSF_Version) then
Write_Str
("| (include your customer number #nnn " &
"in the subject line).");
*************** package body Comperr is
*** 307,313 ****
("| (concatenated together with no headers between files).");
End_Line;
! if Public_Version then
Write_Str
("| (use plain ASCII or MIME attachment).");
End_Line;
--- 304,310 ----
("| (concatenated together with no headers between files).");
End_Line;
! if Is_Public_Version then
Write_Str
("| (use plain ASCII or MIME attachment).");
End_Line;
*************** package body Comperr is
*** 317,323 ****
"for submitting bugs.");
End_Line;
! elsif GNATPRO_Version then
Write_Str
("| (use plain ASCII or MIME attachment, or FTP "
& "to your customer directory).");
--- 314,320 ----
"for submitting bugs.");
End_Line;
! elsif not Is_FSF_Version then
Write_Str
("| (use plain ASCII or MIME attachment, or FTP "
& "to your customer directory).");
Index: cstand.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/cstand.adb,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 cstand.adb
*** cstand.adb 21 Oct 2003 13:41:58 -0000 1.10
--- cstand.adb 10 Nov 2003 16:49:43 -0000
*************** with Namet; use Namet;
*** 33,38 ****
--- 33,39 ----
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
+ with Output; use Output;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
*************** package body CStand is
*** 120,125 ****
--- 121,129 ----
return Entity_Id;
-- Builds a new entity for Standard
+ procedure Print_Standard;
+ -- Print representation of package Standard if switch set
+
procedure Set_Integer_Bounds
(Id : Entity_Id;
Typ : Entity_Id;
*************** package body CStand is
*** 1243,1248 ****
--- 1247,1258 ----
-- The Error node has an Etype of Any_Type to help error recovery
Set_Etype (Error, Any_Type);
+
+ -- Print representation of standard if switch set
+
+ if Opt.Print_Standard then
+ Print_Standard;
+ end if;
end Create_Standard;
------------------------------------
*************** package body CStand is
*** 1416,1421 ****
--- 1426,1674 ----
return E;
end New_Standard_Entity;
+
+ --------------------
+ -- Print_Standard --
+ --------------------
+
+ procedure Print_Standard is
+
+ procedure P (Item : String) renames Output.Write_Line;
+ -- Short-hand, since we do a lot of line writes here!
+
+ procedure P_Int_Range (Size : Pos);
+ -- Prints the range of an integer based on its Size
+
+ procedure P_Float_Range (Id : Entity_Id);
+ -- Prints the bounds range for the given float type entity
+
+ -------------------
+ -- P_Float_Range --
+ -------------------
+
+ procedure P_Float_Range (Id : Entity_Id) is
+ Digs : constant Nat := UI_To_Int (Digits_Value (Id));
+
+ begin
+ Write_Str (" range ");
+
+ if Vax_Float (Id) then
+ if Digs = VAXFF_Digits then
+ Write_Str (VAXFF_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (VAXFF_Last'Universal_Literal_String);
+
+ elsif Digs = VAXDF_Digits then
+ Write_Str (VAXDF_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (VAXDF_Last'Universal_Literal_String);
+
+ else
+ pragma Assert (Digs = VAXGF_Digits);
+
+ Write_Str (VAXGF_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (VAXGF_Last'Universal_Literal_String);
+ end if;
+
+ elsif Is_AAMP_Float (Id) then
+ if Digs = AAMPS_Digits then
+ Write_Str (AAMPS_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (AAMPS_Last'Universal_Literal_String);
+
+ else
+ pragma Assert (Digs = AAMPL_Digits);
+ Write_Str (AAMPL_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (AAMPL_Last'Universal_Literal_String);
+ end if;
+
+ elsif Digs = IEEES_Digits then
+ Write_Str (IEEES_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (IEEES_Last'Universal_Literal_String);
+
+
+ elsif Digs = IEEEL_Digits then
+ Write_Str (IEEEL_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (IEEEL_Last'Universal_Literal_String);
+
+ else
+ pragma Assert (Digs = IEEEX_Digits);
+
+ Write_Str (IEEEX_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (IEEEX_Last'Universal_Literal_String);
+ end if;
+
+ Write_Str (";");
+ Write_Eol;
+ end P_Float_Range;
+
+ -----------------
+ -- P_Int_Range --
+ -----------------
+
+ procedure P_Int_Range (Size : Pos) is
+ begin
+ Write_Str (" is range -(2 **");
+ Write_Int (Size - 1);
+ Write_Str (")");
+ Write_Str (" .. +(2 **");
+ Write_Int (Size - 1);
+ Write_Str (" - 1);");
+ Write_Eol;
+ end P_Int_Range;
+
+ -- Start of processing for Print_Standard
+
+ begin
+ P ("-- Representation of package Standard");
+ Write_Eol;
+ P ("-- This is not accurate Ada, since new base types cannot be ");
+ P ("-- created, but the listing shows the target dependent");
+ P ("-- characteristics of the Standard types for this compiler");
+ Write_Eol;
+
+ P ("package Standard is");
+ P ("pragma Pure(Standard);");
+ Write_Eol;
+
+ P (" type Boolean is (False, True);");
+ P (" for Boolean'Size use 1;");
+ P (" for Boolean use (False => 0, True => 1);");
+ Write_Eol;
+
+ -- Integer types
+
+ Write_Str (" type Integer");
+ P_Int_Range (Standard_Integer_Size);
+ Write_Str (" for Integer'Size use ");
+ Write_Int (Standard_Integer_Size);
+ P (";");
+ Write_Eol;
+
+ P (" subtype Natural is Integer range 0 .. Integer'Last;");
+ P (" subtype Positive is Integer range 1 .. Integer'Last;");
+ Write_Eol;
+
+ Write_Str (" type Short_Short_Integer");
+ P_Int_Range (Standard_Short_Short_Integer_Size);
+ Write_Str (" for Short_Short_Integer'Size use ");
+ Write_Int (Standard_Short_Short_Integer_Size);
+ P (";");
+ Write_Eol;
+
+ Write_Str (" type Short_Integer");
+ P_Int_Range (Standard_Short_Integer_Size);
+ Write_Str (" for Short_Integer'Size use ");
+ Write_Int (Standard_Short_Integer_Size);
+ P (";");
+ Write_Eol;
+
+ Write_Str (" type Long_Integer");
+ P_Int_Range (Standard_Long_Integer_Size);
+ Write_Str (" for Long_Integer'Size use ");
+ Write_Int (Standard_Long_Integer_Size);
+ P (";");
+ Write_Eol;
+
+ Write_Str (" type Long_Long_Integer");
+ P_Int_Range (Standard_Long_Long_Integer_Size);
+ Write_Str (" for Long_Long_Integer'Size use ");
+ Write_Int (Standard_Long_Long_Integer_Size);
+ P (";");
+ Write_Eol;
+
+ -- Floating point types
+
+ Write_Str (" type Short_Float is digits ");
+ Write_Int (Standard_Short_Float_Digits);
+ Write_Eol;
+ P_Float_Range (Standard_Short_Float);
+ Write_Str (" for Short_Float'Size use ");
+ Write_Int (Standard_Short_Float_Size);
+ P (";");
+ Write_Eol;
+
+ Write_Str (" type Float is digits ");
+ Write_Int (Standard_Float_Digits);
+ Write_Eol;
+ P_Float_Range (Standard_Float);
+ Write_Str (" for Float'Size use ");
+ Write_Int (Standard_Float_Size);
+ P (";");
+ Write_Eol;
+
+ Write_Str (" type Long_Float is digits ");
+ Write_Int (Standard_Long_Float_Digits);
+ Write_Eol;
+ P_Float_Range (Standard_Long_Float);
+ Write_Str (" for Long_Float'Size use ");
+ Write_Int (Standard_Long_Float_Size);
+ P (";");
+ Write_Eol;
+
+ Write_Str (" type Long_Long_Float is digits ");
+ Write_Int (Standard_Long_Long_Float_Digits);
+ Write_Eol;
+ P_Float_Range (Standard_Long_Long_Float);
+ Write_Str (" for Long_Long_Float'Size use ");
+ Write_Int (Standard_Long_Long_Float_Size);
+ P (";");
+ Write_Eol;
+
+ P (" type Character is (...)");
+ Write_Str (" for Character'Size use ");
+ Write_Int (Standard_Character_Size);
+ P (";");
+ P (" -- See RM A.1(35) for details of this type");
+ Write_Eol;
+
+ P (" type Wide_Character is (...)");
+ Write_Str (" for Wide_Character'Size use ");
+ Write_Int (Standard_Wide_Character_Size);
+ P (";");
+ P (" -- See RM A.1(36) for details of this type");
+ Write_Eol;
+
+ P (" type String is array (Positive range <>) of Character;");
+ P (" pragma Pack (String);");
+ Write_Eol;
+
+ P (" type Wide_String is array (Positive range <>)" &
+ " of Wide_Character;");
+ P (" pragma Pack (Wide_String);");
+ Write_Eol;
+
+ -- Here it's OK to use the Duration type of the host compiler since
+ -- the implementation of Duration in GNAT is target independent.
+
+ if Duration_32_Bits_On_Target then
+ P (" type Duration is delta 0.020");
+ P (" range -((2 ** 31 - 1) * 0.020) ..");
+ P (" +((2 ** 31 - 1) * 0.020);");
+ P (" for Duration'Small use 0.020;");
+ else
+ P (" type Duration is delta 0.000000001");
+ P (" range -((2 ** 63 - 1) * 0.000000001) ..");
+ P (" +((2 ** 63 - 1) * 0.000000001);");
+ P (" for Duration'Small use 0.000000001;");
+ end if;
+
+ Write_Eol;
+
+ P (" Constraint_Error : exception;");
+ P (" Program_Error : exception;");
+ P (" Storage_Error : exception;");
+ P (" Tasking_Error : exception;");
+ P (" Numeric_Error : exception renames Constraint_Error;");
+ Write_Eol;
+
+ P ("end Standard;");
+ end Print_Standard;
----------------------
-- Set_Float_Bounds --
Index: debug.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/debug.adb,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 debug.adb
*** debug.adb 21 Oct 2003 13:41:58 -0000 1.7
--- debug.adb 10 Nov 2003 16:49:43 -0000
*************** package body Debug is
*** 338,344 ****
-- dz Print source of package Standard. Normally the source print out
-- does not include package Standard, even if the -df switch is set.
-- This switch forces output of the source recreated from the internal
! -- tree built for Standard.
-- dA Forces output of representation information, including full
-- information for all internal type and object entities, as well
--- 338,346 ----
-- dz Print source of package Standard. Normally the source print out
-- does not include package Standard, even if the -df switch is set.
-- This switch forces output of the source recreated from the internal
! -- tree built for Standard. Note that this differs from -gnatS in
! -- that it prints from the actual tree using the normal Sprint
! -- circuitry for printing trees.
-- dA Forces output of representation information, including full
-- information for all internal type and object entities, as well
Index: einfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.ads,v
retrieving revision 1.14
diff -u -c -3 -p -r1.14 einfo.ads
*** einfo.ads 4 Nov 2003 12:51:45 -0000 1.14
--- einfo.ads 10 Nov 2003 16:49:43 -0000
*************** package Einfo is
*** 930,936 ****
-- the record that is the fat pointer representation of an RAST.
-- Esize (Uint12)
! -- Present in all types and subtypes, an also for components, constants,
-- and variables. Contains the Object_Size of the type or of the object.
-- A value of zero indicates that the value is not yet known.
--
--- 930,936 ----
-- the record that is the fat pointer representation of an RAST.
-- Esize (Uint12)
! -- Present in all types and subtypes, and also for components, constants,
-- and variables. Contains the Object_Size of the type or of the object.
-- A value of zero indicates that the value is not yet known.
--
*************** package Einfo is
*** 2830,2836 ****
-- Present in all type and subtype entities. Contains the value of
-- type'Size as defined in the RM. See also the Esize field and
-- and the description on "Handling of Type'Size Values". A value
! -- of zero for in this field for a non-discrete type means that
-- the front end has not yet determined the size value. For the
-- case of a discrete type, this field is always set by the front
-- end and zero is a legitimate value for a type with one value.
--- 2830,2836 ----
-- Present in all type and subtype entities. Contains the value of
-- type'Size as defined in the RM. See also the Esize field and
-- and the description on "Handling of Type'Size Values". A value
! -- of zero in this field for a non-discrete type means that
-- the front end has not yet determined the size value. For the
-- case of a discrete type, this field is always set by the front
-- end and zero is a legitimate value for a type with one value.
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 exp_ch6.adb
*** exp_ch6.adb 4 Nov 2003 12:51:46 -0000 1.10
--- exp_ch6.adb 10 Nov 2003 16:49:43 -0000
*************** package body Exp_Ch6 is
*** 2944,2949 ****
--- 2944,2951 ----
Excep_Handlers : List_Id;
begin
+ New_Scope (Spec_Id);
+
-- Get proper setting for secondary stack size
if List_Length (Pragma_Argument_Associations (TB_Pragma)) = 2 then
*************** package body Exp_Ch6 is
*** 3046,3051 ****
--- 3048,3054 ----
Exception_Handlers => Excep_Handlers));
Analyze (Handled_Statement_Sequence (N));
+ End_Scope;
end Expand_Thread_Body;
-- Start of processing for Expand_N_Subprogram_Body
Index: gnat1drv.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnat1drv.adb,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 gnat1drv.adb
*** gnat1drv.adb 21 Oct 2003 13:42:05 -0000 1.8
--- gnat1drv.adb 10 Nov 2003 16:49:43 -0000
*************** with Sem;
*** 54,59 ****
--- 54,60 ----
with Sem_Ch8;
with Sem_Ch12;
with Sem_Ch13;
+ with Sem_Elim;
with Sem_Eval;
with Sem_Type;
with Sinfo; use Sinfo;
*************** begin
*** 118,123 ****
--- 119,125 ----
Sem_Ch8.Initialize;
Sem_Ch12.Initialize;
Sem_Ch13.Initialize;
+ Sem_Elim.Initialize;
Sem_Eval.Initialize;
Sem_Type.Init_Interp_Tables;
Index: gprcmd.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gprcmd.adb,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 gprcmd.adb
*** gprcmd.adb 21 Oct 2003 13:42:08 -0000 1.1
--- gprcmd.adb 10 Nov 2003 16:49:43 -0000
***************
*** 37,42 ****
--- 37,43 ----
-- extend handle recursive directories ("/**" notation)
-- deps post process dependency makefiles
-- stamp copy file time stamp from file1 to file2
+ -- prefix get the prefix of the GNAT installation
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
*************** with GNAT.OS_Lib; use GNAT
*** 45,50 ****
--- 46,53 ----
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Regpat; use GNAT.Regpat;
with Gnatvsn;
+ with Osint; use Osint;
+ with Namet; use Namet;
procedure Gprcmd is
*************** begin
*** 418,423 ****
--- 421,460 ----
elsif Cmd = "stamp" then
Check_Args (Argument_Count = 3);
Copy_Time_Stamp (Argument (2), Argument (3));
+
+ elsif Cmd = "prefix" then
+
+ -- Find the GNAT prefix. gprcmd is found in <prefix>/bin.
+ -- So we find the full path of gprcmd, verify that it is in a
+ -- subdirectory "bin", and return the <prefix> if it is the case.
+ -- Otherwise, nothing is returned.
+
+ Find_Program_Name;
+
+ declare
+ Path : String_Access :=
+ Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
+ Index : Natural;
+
+ begin
+ if Path /= null then
+ Index := Path'Last;
+
+ while Index >= Path'First + 4 loop
+ exit when Path (Index) = Directory_Separator;
+ Index := Index - 1;
+ end loop;
+
+ if Index > Path'First + 5
+ and then Path (Index - 3 .. Index - 1) = "bin"
+ and then Path (Index - 4) = Directory_Separator
+ then
+ -- We have found the <prefix>, return it.
+
+ Put (Path (Path'First .. Index - 5));
+ end if;
+ end if;
+ end;
end if;
end;
end Gprcmd;
Index: lib.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib.adb,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 lib.adb
*** lib.adb 21 Oct 2003 13:42:09 -0000 1.7
--- lib.adb 10 Nov 2003 16:49:43 -0000
*************** package body Lib is
*** 460,467 ****
end Generic_Separately_Compiled;
function Generic_Separately_Compiled
! (Sfile : File_Name_Type)
! return Boolean
is
begin
-- Exactly the same as previous function, but works directly on a file
--- 460,466 ----
end Generic_Separately_Compiled;
function Generic_Separately_Compiled
! (Sfile : File_Name_Type) return Boolean
is
begin
-- Exactly the same as previous function, but works directly on a file
*************** package body Lib is
*** 534,541 ****
----------------------------------
function Get_Cunit_Entity_Unit_Number
! (E : Entity_Id)
! return Unit_Number_Type
is
begin
for U in Units.First .. Units.Last loop
--- 533,539 ----
----------------------------------
function Get_Cunit_Entity_Unit_Number
! (E : Entity_Id) return Unit_Number_Type
is
begin
for U in Units.First .. Units.Last loop
*************** package body Lib is
*** 613,620 ****
--------------------------------
function In_Extended_Main_Code_Unit
! (N : Node_Or_Entity_Id)
! return Boolean
is
begin
if Sloc (N) = Standard_Location then
--- 611,617 ----
--------------------------------
function In_Extended_Main_Code_Unit
! (N : Node_Or_Entity_Id) return Boolean
is
begin
if Sloc (N) = Standard_Location then
*************** package body Lib is
*** 647,656 ****
end if;
end In_Extended_Main_Code_Unit;
! function In_Extended_Main_Code_Unit
! (Loc : Source_Ptr)
! return Boolean
! is
begin
if Loc = Standard_Location then
return True;
--- 644,650 ----
end if;
end In_Extended_Main_Code_Unit;
! function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean is
begin
if Loc = Standard_Location then
return True;
*************** package body Lib is
*** 676,683 ****
----------------------------------
function In_Extended_Main_Source_Unit
! (N : Node_Or_Entity_Id)
! return Boolean
is
Nloc : constant Source_Ptr := Sloc (N);
Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
--- 670,676 ----
----------------------------------
function In_Extended_Main_Source_Unit
! (N : Node_Or_Entity_Id) return Boolean
is
Nloc : constant Source_Ptr := Sloc (N);
Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
*************** package body Lib is
*** 718,725 ****
end In_Extended_Main_Source_Unit;
function In_Extended_Main_Source_Unit
! (Loc : Source_Ptr)
! return Boolean
is
Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
--- 711,717 ----
end In_Extended_Main_Source_Unit;
function In_Extended_Main_Source_Unit
! (Loc : Source_Ptr) return Boolean
is
Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
Index: lib.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib.ads,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 lib.ads
*** lib.ads 21 Oct 2003 13:42:09 -0000 1.6
--- lib.ads 10 Nov 2003 16:49:44 -0000
*************** package Lib is
*** 462,469 ****
-- and False otherwise.
function In_Extended_Main_Code_Unit
! (N : Node_Or_Entity_Id)
! return Boolean;
-- Return True if the node is in the generated code of the extended main
-- unit, defined as the main unit, its specification (if any), and all
-- its subunits (considered recursively). Units for which this enquiry
--- 462,468 ----
-- and False otherwise.
function In_Extended_Main_Code_Unit
! (N : Node_Or_Entity_Id) return Boolean;
-- Return True if the node is in the generated code of the extended main
-- unit, defined as the main unit, its specification (if any), and all
-- its subunits (considered recursively). Units for which this enquiry
*************** package Lib is
*** 472,486 ****
-- If the main unit is itself a subunit, then the extended main unit
-- includes its parent unit, and the parent unit spec if it is separate.
! function In_Extended_Main_Code_Unit
! (Loc : Source_Ptr)
! return Boolean;
-- Same function as above, but argument is a source pointer rather
-- than a node.
function In_Extended_Main_Source_Unit
! (N : Node_Or_Entity_Id)
! return Boolean;
-- Return True if the node is in the source text of the extended main
-- unit, defined as the main unit, its specification (if any), and all
-- its subunits (considered recursively). Units for which this enquiry
--- 471,482 ----
-- If the main unit is itself a subunit, then the extended main unit
-- includes its parent unit, and the parent unit spec if it is separate.
! function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean;
-- Same function as above, but argument is a source pointer rather
-- than a node.
function In_Extended_Main_Source_Unit
! (N : Node_Or_Entity_Id) return Boolean;
-- Return True if the node is in the source text of the extended main
-- unit, defined as the main unit, its specification (if any), and all
-- its subunits (considered recursively). Units for which this enquiry
*************** package Lib is
*** 490,498 ****
-- a subunit, then the extended main unit includes its parent unit,
-- and the parent unit spec if it is separate.
! function In_Extended_Main_Source_Unit
! (Loc : Source_Ptr)
! return Boolean;
-- Same function as above, but argument is a source pointer rather
-- than a node.
--- 486,492 ----
-- a subunit, then the extended main unit includes its parent unit,
-- and the parent unit spec if it is separate.
! function In_Extended_Main_Source_Unit (Loc : Source_Ptr) return Boolean;
-- Same function as above, but argument is a source pointer rather
-- than a node.
*************** package Lib is
*** 515,522 ****
-- could not have been built without making a unit table entry.
function Get_Cunit_Entity_Unit_Number
! (E : Entity_Id)
! return Unit_Number_Type;
-- Return unit number of the unit whose compilation unit spec entity is
-- the one passed as an argument. This must always succeed since the
-- entity could not have been built without making a unit table entry.
--- 509,515 ----
-- could not have been built without making a unit table entry.
function Get_Cunit_Entity_Unit_Number
! (E : Entity_Id) return Unit_Number_Type;
-- Return unit number of the unit whose compilation unit spec entity is
-- the one passed as an argument. This must always succeed since the
-- entity could not have been built without making a unit table entry.
*************** package Lib is
*** 603,610 ****
-- compiled with the current approach.
function Generic_Separately_Compiled
! (Sfile : File_Name_Type)
! return Boolean;
-- Same as the previous function, but works directly on a unit file name.
private
--- 596,602 ----
-- compiled with the current approach.
function Generic_Separately_Compiled
! (Sfile : File_Name_Type) return Boolean;
-- Same as the previous function, but works directly on a unit file name.
private
Index: lib-load.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-load.adb,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 lib-load.adb
*** lib-load.adb 21 Oct 2003 13:42:09 -0000 1.6
--- lib-load.adb 10 Nov 2003 16:49:44 -0000
*************** package body Lib.Load is
*** 78,84 ****
is
Unum : Unit_Number_Type;
Cunit_Entity : Entity_Id;
- Scope_Entity : Entity_Id;
Cunit : Node_Id;
Du_Name : Node_Or_Entity_Id;
End_Lab : Node_Id;
--- 78,83 ----
*************** package body Lib.Load is
*** 98,108 ****
Du_Name := Cunit_Entity;
End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location);
- Scope_Entity := Standard_Standard;
-
-- Child package
! else -- Nkind (Name (With_Node)) = N_Expanded_Name
Cunit_Entity :=
Make_Defining_Identifier (No_Location,
Chars => Chars (Selector_Name (Name (With_Node))));
--- 97,108 ----
Du_Name := Cunit_Entity;
End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location);
-- Child package
! else
!
! -- Nkind (Name (With_Node)) = N_Expanded_Name
!
Cunit_Entity :=
Make_Defining_Identifier (No_Location,
Chars => Chars (Selector_Name (Name (With_Node))));
*************** package body Lib.Load is
*** 113,131 ****
Set_Is_Child_Unit (Cunit_Entity);
- if Nkind (Du_Name) = N_Defining_Program_Unit_Name then
- Scope_Entity := Defining_Identifier (Du_Name);
- else
- Scope_Entity := Du_Name;
- end if;
-
End_Lab :=
Make_Designator (No_Location,
Name => New_Copy_Tree (Prefix (Name (With_Node))),
Identifier => New_Occurrence_Of (Cunit_Entity, No_Location));
end if;
! Set_Scope (Cunit_Entity, Scope_Entity);
Cunit :=
Make_Compilation_Unit (No_Location,
--- 113,126 ----
Set_Is_Child_Unit (Cunit_Entity);
End_Lab :=
Make_Designator (No_Location,
Name => New_Copy_Tree (Prefix (Name (With_Node))),
Identifier => New_Occurrence_Of (Cunit_Entity, No_Location));
+
end if;
! Set_Scope (Cunit_Entity, Standard_Standard);
Cunit :=
Make_Compilation_Unit (No_Location,
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.21
diff -u -c -3 -p -r1.21 make.adb
*** make.adb 4 Nov 2003 12:51:46 -0000 1.21
--- make.adb 10 Nov 2003 16:49:44 -0000
*************** package body Make is
*** 3595,3601 ****
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
--- 3595,3601 ----
end loop Look_For_Foreign;
end if;
! -- Then, find all mains, or if there is a foreign
-- language, all the Ada mains.
while Value /= Prj.Nil_String loop
*************** package body Make is
*** 6848,6858 ****
-- linking with all standard library files.
Opt.No_Stdlib := True;
Add_Switch (Argv, Binder, And_Save => And_Save);
elsif Argv (2 .. Argv'Last) = "nostdinc" then
! -- Pass -nostdinv to the Compiler and to gnatbind
Opt.No_Stdinc := True;
Add_Switch (Argv, Compiler, And_Save => And_Save);
--- 6848,6860 ----
-- linking with all standard library files.
Opt.No_Stdlib := True;
+
+ Add_Switch (Argv, Compiler, And_Save => And_Save);
Add_Switch (Argv, Binder, And_Save => And_Save);
elsif Argv (2 .. Argv'Last) = "nostdinc" then
! -- Pass -nostdinc to the Compiler and to gnatbind
Opt.No_Stdinc := True;
Add_Switch (Argv, Compiler, And_Save => And_Save);
Index: opt.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/opt.ads,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 opt.ads
*** opt.ads 21 Oct 2003 13:42:10 -0000 1.9
--- opt.ads 10 Nov 2003 16:49:44 -0000
*************** package Opt is
*** 719,724 ****
--- 719,729 ----
-- Set to True to enable output of generated code in source form. This
-- flag is set by the -gnatG switch.
+ Print_Standard : Boolean := False;
+ -- GNAT
+ -- Set to true to enable printing of package standard in source form.
+ -- This flag is set by the -gnatS switch
+
Propagate_Exceptions : Boolean := False;
-- GNAT
-- Indicates if subprogram descriptor exception tables should be
Index: prj.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj.adb,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 prj.adb
*** prj.adb 21 Oct 2003 13:42:12 -0000 1.10
--- prj.adb 10 Nov 2003 16:49:44 -0000
*************** package body Prj is
*** 77,82 ****
--- 77,83 ----
(First_Referred_By => No_Project,
Name => No_Name,
Path_Name => No_Name,
+ Virtual => False,
Display_Path_Name => No_Name,
Location => No_Location,
Mains => Nil_String,
Index: prj.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj.ads,v
retrieving revision 1.12
diff -u -c -3 -p -r1.12 prj.ads
*** prj.ads 21 Oct 2003 13:42:12 -0000 1.12
--- prj.ads 10 Nov 2003 16:49:44 -0000
*************** package Prj is
*** 47,52 ****
--- 47,56 ----
-- Default value of parameter Packages of procedures Parse, in Prj.Pars and
-- Prj.Part, indicating that all packages should be checked.
+ Virtual_Prefix : constant String := "v$";
+ -- The prefix for virtual extending projects. Because of the '$', which is
+ -- normally forbidden for project names, there cannot be any name clash.
+
Project_File_Extension : String := ".gpr";
-- The standard project file name extension.
-- It is not a constant, because Canonical_Case_File_Name is called
*************** package Prj is
*** 338,343 ****
--- 342,350 ----
Path_Name : Name_Id := No_Name;
-- The path name of the project file.
-- Set by Prj.Proc.Process.
+
+ Virtual : Boolean := False;
+ -- True for virtual extending projects
Display_Path_Name : Name_Id := No_Name;
Index: prj-nmsc.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-nmsc.adb,v
retrieving revision 1.12
diff -u -c -3 -p -r1.12 prj-nmsc.adb
*** prj-nmsc.adb 21 Oct 2003 13:42:12 -0000 1.12
--- prj-nmsc.adb 10 Nov 2003 16:49:44 -0000
*************** package body Prj.Nmsc is
*** 2973,2983 ****
end if;
if Lib_Dir.Default then
! Error_Msg
! (Project,
! "a project extending a library project must specify " &
! "an attribute Library_Dir",
! Data.Location);
end if;
Projects.Table (Data.Extends).Library := False;
--- 2973,3000 ----
end if;
if Lib_Dir.Default then
!
! -- If the extending project is a virtual project, we
! -- put the error message in the library project that
! -- is extended, rather than in the extending all project.
! -- Of course, we cannot put it in the virtual extending
! -- project, because it has no source.
!
! if Data.Virtual then
! Error_Msg_Name_1 := Extended_Data.Name;
!
! Error_Msg
! (Project,
! "library project % cannot be virtually extended",
! Extended_Data.Location);
!
! else
! Error_Msg
! (Project,
! "a project extending a library project must " &
! "specify an attribute Library_Dir",
! Data.Location);
! end if;
end if;
Projects.Table (Data.Extends).Library := False;
*************** package body Prj.Nmsc is
*** 3001,3006 ****
--- 3018,3024 ----
Data.Library_Dir, Data.Display_Library_Dir);
if Data.Library_Dir = No_Name then
+
-- Get the absolute name of the library directory that
-- does not exist, to report an error.
Index: prj-part.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-part.adb,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 prj-part.adb
*** prj-part.adb 21 Oct 2003 13:42:12 -0000 1.8
--- prj-part.adb 10 Nov 2003 16:49:44 -0000
*************** with Prj.Err; use Prj.Err;
*** 35,40 ****
--- 35,41 ----
with Scans; use Scans;
with Sinput; use Sinput;
with Sinput.P; use Sinput.P;
+ with Snames;
with Table;
with Types; use Types;
*************** with Ada.Exceptions; use Ada
*** 44,49 ****
--- 45,52 ----
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
+ with System.HTable; use System.HTable;
+
pragma Elaborate_All (GNAT.OS_Lib);
package body Prj.Part is
*************** package body Prj.Part is
*** 62,67 ****
--- 65,75 ----
-- The path name(s) of directories where project files may reside.
-- May be empty.
+ type Extension_Origin is (None, Extending_Simple, Extending_All);
+ -- Type of parameter From_Extended for procedures Parse_Single_Project and
+ -- Post_Parse_Context_Clause. Extending_All means that we are parsing the
+ -- tree rooted at an extending all project.
+
------------------------------------
-- Local Packages and Subprograms --
------------------------------------
*************** package body Prj.Part is
*** 105,110 ****
--- 113,154 ----
-- limited imported projects when there is a circularity with at least
-- one limited imported project file.
+ package Virtual_Hash is new Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Project_Node_Id,
+ No_Element => Empty_Node,
+ Key => Project_Node_Id,
+ Hash => Prj.Tree.Hash,
+ Equal => "=");
+ -- Hash table to store the node id of the project for which a virtual
+ -- extending project need to be created.
+
+ package Processed_Hash is new Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => Project_Node_Id,
+ Hash => Prj.Tree.Hash,
+ Equal => "=");
+ -- Hash table to store the project process when looking for project that
+ -- need to have a virtual extending project, to avoid processing the same
+ -- project twice.
+
+ procedure Create_Virtual_Extending_Project
+ (For_Project : Project_Node_Id;
+ Main_Project : Project_Node_Id);
+ -- Create a virtual extending project of For_Project. Main_Project is
+ -- the extending all project.
+
+ procedure Look_For_Virtual_Projects_For
+ (Proj : Project_Node_Id;
+ Potentially_Virtual : Boolean);
+ -- Look for projects that need to have a virtual extending project.
+ -- This procedure is recursive. If called with Potentially_Virtual set to
+ -- True, then Proj may need an virtual extending project; otherwise it
+ -- does not (because it is already extended), but other projects that it
+ -- imports may need to be virtually extended.
+
procedure Pre_Parse_Context_Clause (Context_Clause : out With_Id);
-- Parse the context clause of a project.
-- Store the paths and locations of the imported projects in table Withs.
*************** package body Prj.Part is
*** 115,121 ****
(Context_Clause : With_Id;
Imported_Projects : out Project_Node_Id;
Project_Directory : Name_Id;
! From_Extended : Boolean);
-- Parse the imported projects that have been stored in table Withs,
-- if any. From_Extended is used for the call to Parse_Single_Project
-- below.
--- 159,165 ----
(Context_Clause : With_Id;
Imported_Projects : out Project_Node_Id;
Project_Directory : Name_Id;
! From_Extended : Extension_Origin);
-- Parse the imported projects that have been stored in table Withs,
-- if any. From_Extended is used for the call to Parse_Single_Project
-- below.
*************** package body Prj.Part is
*** 124,133 ****
(Project : out Project_Node_Id;
Path_Name : String;
Extended : Boolean;
! From_Extended : Boolean);
-- Parse a project file.
-- Recursive procedure: it calls itself for imported and extended
! -- projects. When From_Extended is True, if the project has already
-- been parsed and is an extended project A, return the ultimate
-- (not extended) project that extends A.
--- 168,177 ----
(Project : out Project_Node_Id;
Path_Name : String;
Extended : Boolean;
! From_Extended : Extension_Origin);
-- Parse a project file.
-- Recursive procedure: it calls itself for imported and extended
! -- projects. When From_Extended is not None, if the project has already
-- been parsed and is an extended project A, return the ultimate
-- (not extended) project that extends A.
*************** package body Prj.Part is
*** 148,153 ****
--- 192,323 ----
-- Returns No_Name if the path name is invalid, because the corresponding
-- project name does not have the syntax of an ada identifier.
+ --------------------------------------
+ -- Create_Virtual_Extending_Project --
+ --------------------------------------
+
+ procedure Create_Virtual_Extending_Project
+ (For_Project : Project_Node_Id;
+ Main_Project : Project_Node_Id)
+ is
+
+ Virtual_Name : constant String :=
+ Virtual_Prefix &
+ Get_Name_String (Name_Of (For_Project));
+ -- The name of the virtual extending project
+
+ Virtual_Name_Id : Name_Id;
+ -- Virtual extending project name id
+
+ Virtual_Path_Id : Name_Id;
+ -- Fake path name of the virtual extending project. The directory is
+ -- the same directory as the extending all project.
+
+ Virtual_Dir_Id : constant Name_Id :=
+ Immediate_Directory_Of (Path_Name_Of (Main_Project));
+ -- The directory of the extending all project
+
+ -- The source of the virtual extending project is something like:
+
+ -- project V$<project name> extends <project path> is
+
+ -- for Source_Dirs use ();
+
+ -- end V$<project name>;
+
+ -- The project directory cannot be specified during parsing; it will be
+ -- put directly in the virtual extending project data during processing.
+
+ -- Nodes that made up the virtual extending project
+
+ Virtual_Project : constant Project_Node_Id :=
+ Default_Project_Node (N_Project);
+ With_Clause : constant Project_Node_Id :=
+ Default_Project_Node (N_With_Clause);
+ Project_Declaration : constant Project_Node_Id :=
+ Default_Project_Node (N_Project_Declaration);
+ Source_Dirs_Declaration : constant Project_Node_Id :=
+ Default_Project_Node (N_Declarative_Item);
+ Source_Dirs_Attribute : constant Project_Node_Id :=
+ Default_Project_Node
+ (N_Attribute_Declaration, List);
+ Source_Dirs_Expression : constant Project_Node_Id :=
+ Default_Project_Node (N_Expression, List);
+ Source_Dirs_Term : constant Project_Node_Id :=
+ Default_Project_Node (N_Term, List);
+ Source_Dirs_List : constant Project_Node_Id :=
+ Default_Project_Node
+ (N_Literal_String_List, List);
+
+ begin
+ -- Get the virtual name id
+
+ Name_Len := Virtual_Name'Length;
+ Name_Buffer (1 .. Name_Len) := Virtual_Name;
+ Virtual_Name_Id := Name_Find;
+
+ -- Get the virtual path name
+
+ Get_Name_String (Path_Name_Of (Main_Project));
+
+ while Name_Len > 0
+ and then Name_Buffer (Name_Len) /= Directory_Separator
+ and then Name_Buffer (Name_Len) /= '/'
+ loop
+ Name_Len := Name_Len - 1;
+ end loop;
+
+ Name_Buffer (Name_Len + 1 .. Name_Len + Virtual_Name'Length) :=
+ Virtual_Name;
+ Name_Len := Name_Len + Virtual_Name'Length;
+ Virtual_Path_Id := Name_Find;
+
+ -- With clause
+
+ Set_Name_Of (With_Clause, Virtual_Name_Id);
+ Set_Path_Name_Of (With_Clause, Virtual_Path_Id);
+ Set_Project_Node_Of (With_Clause, Virtual_Project);
+ Set_Next_With_Clause_Of
+ (With_Clause, First_With_Clause_Of (Main_Project));
+ Set_First_With_Clause_Of (Main_Project, With_Clause);
+
+ -- Virtual project node
+
+ Set_Name_Of (Virtual_Project, Virtual_Name_Id);
+ Set_Path_Name_Of (Virtual_Project, Virtual_Path_Id);
+ Set_Location_Of (Virtual_Project, Location_Of (Main_Project));
+ Set_Directory_Of (Virtual_Project, Virtual_Dir_Id);
+ Set_Project_Declaration_Of (Virtual_Project, Project_Declaration);
+ Set_Extended_Project_Path_Of
+ (Virtual_Project, Path_Name_Of (For_Project));
+
+ -- Project declaration
+
+ Set_First_Declarative_Item_Of
+ (Project_Declaration, Source_Dirs_Declaration);
+ Set_Extended_Project_Of (Project_Declaration, For_Project);
+
+ -- Source_Dirs declaration
+
+ Set_Current_Item_Node (Source_Dirs_Declaration, Source_Dirs_Attribute);
+
+ -- Source_Dirs attribute
+
+ Set_Name_Of (Source_Dirs_Attribute, Snames.Name_Source_Dirs);
+ Set_Expression_Of (Source_Dirs_Attribute, Source_Dirs_Expression);
+
+ -- Source_Dirs expression
+
+ Set_First_Term (Source_Dirs_Expression, Source_Dirs_Term);
+
+ -- Source_Dirs term
+
+ Set_Current_Term (Source_Dirs_Term, Source_Dirs_List);
+
+ -- Source_Dirs empty list: nothing to do
+
+ end Create_Virtual_Extending_Project;
+
----------------------------
-- Immediate_Directory_Of --
----------------------------
*************** package body Prj.Part is
*** 181,186 ****
--- 351,423 ----
return Name_Find;
end Immediate_Directory_Of;
+ -----------------------------------
+ -- Look_For_Virtual_Projects_For --
+ -----------------------------------
+
+ procedure Look_For_Virtual_Projects_For
+ (Proj : Project_Node_Id;
+ Potentially_Virtual : Boolean)
+
+ is
+ Declaration : Project_Node_Id := Empty_Node;
+ -- Node for the project declaration of Proj
+
+ With_Clause : Project_Node_Id := Empty_Node;
+ -- Node for a with clause of Proj
+
+ Imported : Project_Node_Id := Empty_Node;
+ -- Node for a project imported by Proj
+
+ Extended : Project_Node_Id := Empty_Node;
+ -- Node for the eventual project extended by Proj
+
+ begin
+ -- Nothing to do if Proj is not defined or if it has already been
+ -- processed.
+
+ if Proj /= Empty_Node and then not Processed_Hash.Get (Proj) then
+ -- Make sure the project will not be processed again
+
+ Processed_Hash.Set (Proj, True);
+
+ Declaration := Project_Declaration_Of (Proj);
+
+ if Declaration /= Empty_Node then
+ Extended := Extended_Project_Of (Declaration);
+ end if;
+
+ -- If this is a project that may need a virtual extending project
+ -- and it is not itself an extending project, put it in the list.
+
+ if Potentially_Virtual and then Extended = Empty_Node then
+ Virtual_Hash.Set (Proj, Proj);
+ end if;
+
+ -- Now check the projects it imports
+
+ With_Clause := First_With_Clause_Of (Proj);
+
+ while With_Clause /= Empty_Node loop
+ Imported := Project_Node_Of (With_Clause);
+
+ if Imported /= Empty_Node then
+ Look_For_Virtual_Projects_For
+ (Imported, Potentially_Virtual => True);
+ end if;
+
+ With_Clause := Next_With_Clause_Of (With_Clause);
+ end loop;
+
+ -- Check also the eventual project extended by Proj. As this project
+ -- is already extended, call recursively with Potentially_Virtual
+ -- being False.
+
+ Look_For_Virtual_Projects_For
+ (Extended, Potentially_Virtual => False);
+ end if;
+ end Look_For_Virtual_Projects_For;
+
-----------
-- Parse --
-----------
*************** package body Prj.Part is
*** 228,234 ****
(Project => Project,
Path_Name => Path_Name,
Extended => False,
! From_Extended => False);
-- If there were any kind of error during the parsing, serious
-- or not, then the parsing fails.
--- 465,548 ----
(Project => Project,
Path_Name => Path_Name,
Extended => False,
! From_Extended => None);
!
! -- If Project is an extending-all project, create the eventual
! -- virtual extending projects and check that there are no illegally
! -- imported projects.
!
! if Project /= Empty_Node and then Is_Extending_All (Project) then
! -- First look for projects that potentially need a virtual
! -- extending project.
!
! Virtual_Hash.Reset;
! Processed_Hash.Reset;
!
! -- Mark the extending all project as processed, to avoid checking
! -- the imported projects in case of a "limited with" on this
! -- extending all project.
!
! Processed_Hash.Set (Project, True);
!
! declare
! Declaration : constant Project_Node_Id :=
! Project_Declaration_Of (Project);
! begin
! Look_For_Virtual_Projects_For
! (Extended_Project_Of (Declaration),
! Potentially_Virtual => False);
! end;
!
! -- Now, check the projects directly imported by the main project.
! -- Remove from the potentially virtual any project extended by one
! -- of these imported projects. For non extending imported
! -- projects, check that they do not belong to the project tree of
! -- the project being "extended-all" by the main project.
!
! declare
! With_Clause : Project_Node_Id :=
! First_With_Clause_Of (Project);
! Imported : Project_Node_Id := Empty_Node;
! Declaration : Project_Node_Id := Empty_Node;
!
! begin
! while With_Clause /= Empty_Node loop
! Imported := Project_Node_Of (With_Clause);
!
! if Imported /= Empty_Node then
! Declaration := Project_Declaration_Of (Imported);
!
! if Extended_Project_Of (Declaration) /= Empty_Node then
! loop
! Imported := Extended_Project_Of (Declaration);
! exit when Imported = Empty_Node;
! Virtual_Hash.Remove (Imported);
! Declaration := Project_Declaration_Of (Imported);
! end loop;
!
! elsif Virtual_Hash.Get (Imported) /= Empty_Node then
! Error_Msg
! ("this project cannot be imported directly",
! Location_Of (With_Clause));
! end if;
!
! end if;
!
! With_Clause := Next_With_Clause_Of (With_Clause);
! end loop;
! end;
!
! -- Now create all the virtual extending projects
!
! declare
! Proj : Project_Node_Id := Virtual_Hash.Get_First;
! begin
! while Proj /= Empty_Node loop
! Create_Virtual_Extending_Project (Proj, Project);
! Proj := Virtual_Hash.Get_Next;
! end loop;
! end;
! end if;
-- If there were any kind of error during the parsing, serious
-- or not, then the parsing fails.
*************** package body Prj.Part is
*** 338,344 ****
(Context_Clause : With_Id;
Imported_Projects : out Project_Node_Id;
Project_Directory : Name_Id;
! From_Extended : Boolean)
is
Current_With_Clause : With_Id := Context_Clause;
--- 652,658 ----
(Context_Clause : With_Id;
Imported_Projects : out Project_Node_Id;
Project_Directory : Name_Id;
! From_Extended : Extension_Origin)
is
Current_With_Clause : With_Id := Context_Clause;
*************** package body Prj.Part is
*** 494,500 ****
(Project : out Project_Node_Id;
Path_Name : String;
Extended : Boolean;
! From_Extended : Boolean)
is
Normed_Path_Name : Name_Id;
Canonical_Path_Name : Name_Id;
--- 808,814 ----
(Project : out Project_Node_Id;
Path_Name : String;
Extended : Boolean;
! From_Extended : Extension_Origin)
is
Normed_Path_Name : Name_Id;
Canonical_Path_Name : Name_Id;
*************** package body Prj.Part is
*** 583,589 ****
-- in an extended project, replace A with the ultimate project
-- extending A.
! if From_Extended then
declare
Decl : Project_Node_Id :=
Project_Declaration_Of
--- 897,903 ----
-- in an extended project, replace A with the ultimate project
-- extending A.
! if From_Extended /= None then
declare
Decl : Project_Node_Id :=
Project_Declaration_Of
*************** package body Prj.Part is
*** 745,757 ****
declare
Imported_Projects : Project_Node_Id := Empty_Node;
begin
Post_Parse_Context_Clause
(Context_Clause => First_With,
Imported_Projects => Imported_Projects,
Project_Directory => Project_Directory,
! From_Extended => Extended);
Set_First_With_Clause_Of (Project, Imported_Projects);
end;
--- 1059,1084 ----
declare
Imported_Projects : Project_Node_Id := Empty_Node;
+ From_Ext : Extension_Origin := None;
begin
+ -- Extending_All is always propagated
+
+ if From_Extended = Extending_All then
+ From_Ext := Extending_All;
+
+ -- Otherwise, From_Extended is set to Extending_Single if the
+ -- current project is an extending project.
+
+ elsif Extended then
+ From_Ext := Extending_Simple;
+ end if;
+
Post_Parse_Context_Clause
(Context_Clause => First_With,
Imported_Projects => Imported_Projects,
Project_Directory => Project_Directory,
! From_Extended => From_Ext);
Set_First_With_Clause_Of (Project, Imported_Projects);
end;
*************** package body Prj.Part is
*** 797,802 ****
--- 1124,1135 ----
-- We are extending another project
Scan; -- scan past EXTENDS
+
+ if Token = Tok_All then
+ Set_Is_Extending_All (Project);
+ Scan; -- scan past ALL
+ end if;
+
Expect (Tok_String_Literal, "literal string");
if Token = Tok_String_Literal then
*************** package body Prj.Part is
*** 836,851 ****
end if;
else
! Parse_Single_Project
! (Project => Extended_Project,
! Path_Name => Extended_Project_Path_Name,
! Extended => True,
! From_Extended => False);
end if;
end;
Scan; -- scan past the extended project path
end if;
end if;
-- Check that a project with a name including a dot either imports
--- 1169,1224 ----
end if;
else
! declare
! From_Extended : Extension_Origin := None;
!
! begin
! if Is_Extending_All (Project) then
! From_Extended := Extending_All;
! end if;
!
! Parse_Single_Project
! (Project => Extended_Project,
! Path_Name => Extended_Project_Path_Name,
! Extended => True,
! From_Extended => From_Extended);
! end;
!
! -- A project that extends an extending-all project is also
! -- an extending-all project.
!
! if Is_Extending_All (Extended_Project) then
! Set_Is_Extending_All (Project);
! end if;
end if;
end;
Scan; -- scan past the extended project path
end if;
+ end if;
+
+ -- Check that a non extending-all project does not import an
+ -- extending-all project.
+
+ if not Is_Extending_All (Project) then
+ declare
+ With_Clause : Project_Node_Id := First_With_Clause_Of (Project);
+ Imported : Project_Node_Id := Empty_Node;
+
+ begin
+ With_Clause_Loop :
+ while With_Clause /= Empty_Node loop
+ Imported := Project_Node_Of (With_Clause);
+ With_Clause := Next_With_Clause_Of (With_Clause);
+
+ if Is_Extending_All (Imported) then
+ Error_Msg_Name_1 := Name_Of (Imported);
+ Error_Msg ("cannot import extending-all project {",
+ Token_Ptr);
+ exit With_Clause_Loop;
+ end if;
+ end loop With_Clause_Loop;
+ end;
end if;
-- Check that a project with a name including a dot either imports
Index: prj-proc.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-proc.adb,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 prj-proc.adb
*** prj-proc.adb 21 Oct 2003 13:42:12 -0000 1.9
--- prj-proc.adb 10 Nov 2003 16:49:44 -0000
*************** package body Prj.Proc is
*** 840,845 ****
--- 840,864 ----
Check (Project);
end if;
+ -- If main project is an extending all project, set the object
+ -- directory of all virtual extending projects to the object directory
+ -- of the main project.
+
+ if Project /= No_Project
+ and then Is_Extending_All (From_Project_Node)
+ then
+ declare
+ Object_Dir : constant Name_Id :=
+ Projects.Table (Project).Object_Directory;
+ begin
+ for Index in Projects.First .. Projects.Last loop
+ if Projects.Table (Index).Virtual then
+ Projects.Table (Index).Object_Directory := Object_Dir;
+ end if;
+ end loop;
+ end;
+ end if;
+
-- Check that no extended project shares its object directory with
-- another project.
*************** package body Prj.Proc is
*** 855,874 ****
and then Projects.Table (Prj).Sources_Present
and then Projects.Table (Prj).Object_Directory = Obj_Dir
then
! Error_Msg_Name_1 := Projects.Table (Extending).Name;
! Error_Msg_Name_2 := Projects.Table (Extended).Name;
! if Error_Report = null then
! Error_Msg ("project % cannot extend project %",
! Projects.Table (Extending).Location);
else
! Error_Report
! ("project """ &
! Get_Name_String (Error_Msg_Name_1) &
! """ cannot extend project """ &
! Get_Name_String (Error_Msg_Name_2) & '"',
! Project);
end if;
Error_Msg_Name_1 := Projects.Table (Extended).Name;
--- 874,912 ----
and then Projects.Table (Prj).Sources_Present
and then Projects.Table (Prj).Object_Directory = Obj_Dir
then
! if Projects.Table (Extending).Virtual then
! Error_Msg_Name_1 := Projects.Table (Extended).Name;
! if Error_Report = null then
! Error_Msg
! ("project % cannot be extended by " &
! "a virtual project",
! Projects.Table (Extending).Location);
!
! else
! Error_Report
! ("project """ &
! Get_Name_String (Error_Msg_Name_1) &
! """ cannot be extended by a virtual project",
! Project);
! end if;
else
! Error_Msg_Name_1 := Projects.Table (Extending).Name;
! Error_Msg_Name_2 := Projects.Table (Extended).Name;
!
! if Error_Report = null then
! Error_Msg ("project % cannot extend project %",
! Projects.Table (Extending).Location);
!
! else
! Error_Report
! ("project """ &
! Get_Name_String (Error_Msg_Name_1) &
! """ cannot extend project """ &
! Get_Name_String (Error_Msg_Name_2) & '"',
! Project);
! end if;
end if;
Error_Msg_Name_1 := Projects.Table (Extended).Name;
*************** package body Prj.Proc is
*** 1788,1793 ****
--- 1826,1843 ----
Processed_Projects.Set (Name, Project);
Processed_Data.Name := Name;
+
+ Get_Name_String (Name);
+
+ -- If name starts with the virtual prefix, flag the project as
+ -- being a virtual extending project.
+
+ if Name_Len > Virtual_Prefix'Length
+ and then Name_Buffer (1 .. Virtual_Prefix'Length) =
+ Virtual_Prefix
+ then
+ Processed_Data.Virtual := True;
+ end if;
Processed_Data.Display_Path_Name :=
Path_Name_Of (From_Project_Node);
Index: prj-tree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-tree.adb,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 prj-tree.adb
*** prj-tree.adb 21 Oct 2003 13:42:12 -0000 1.7
--- prj-tree.adb 10 Nov 2003 16:49:44 -0000
*************** package body Prj.Tree is
*** 166,172 ****
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
! Case_Insensitive => False);
return Project_Nodes.Last;
end Default_Project_Node;
--- 166,173 ----
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
! Case_Insensitive => False,
! Extending_All => False);
return Project_Nodes.Last;
end Default_Project_Node;
*************** package body Prj.Tree is
*** 485,490 ****
--- 486,504 ----
return Project_Nodes.Table (Node).Field1;
end First_With_Clause_Of;
+ ----------------------
+ -- Is_Extending_All --
+ ----------------------
+
+ function Is_Extending_All (Node : Project_Node_Id) return Boolean is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Project);
+ return Project_Nodes.Table (Node).Extending_All;
+ end Is_Extending_All;
+
----------
-- Hash --
----------
*************** package body Prj.Tree is
*** 1236,1241 ****
--- 1250,1268 ----
Project_Nodes.Table (Node).Kind = N_Project);
Project_Nodes.Table (Node).Field1 := To;
end Set_First_With_Clause_Of;
+
+ --------------------------
+ -- Set_Is_Extending_All --
+ --------------------------
+
+ procedure Set_Is_Extending_All (Node : Project_Node_Id) is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Project);
+ Project_Nodes.Table (Node).Extending_All := True;
+ end Set_Is_Extending_All;
-----------------
-- Set_Kind_Of --
Index: prj-tree.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-tree.ads,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 prj-tree.ads
*** prj-tree.ads 21 Oct 2003 13:42:12 -0000 1.9
--- prj-tree.ads 10 Nov 2003 16:49:44 -0000
*************** package Prj.Tree is
*** 135,140 ****
--- 135,144 ----
-- N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression,
-- N_Term, N_Variable_Reference or N_Attribute_Reference nodes.
+ function Is_Extending_All (Node : Project_Node_Id) return Boolean;
+ pragma Inline (Is_Extending_All);
+ -- Only valid for N_Project
+
function First_Variable_Of
(Node : Project_Node_Id)
return Variable_Node_Id;
*************** package Prj.Tree is
*** 220,226 ****
(Node : Project_Node_Id)
return Project_Node_Id;
pragma Inline (Extended_Project_Of);
! -- Only valid for N_With_Clause nodes
function Current_Item_Node
(Node : Project_Node_Id)
--- 224,230 ----
(Node : Project_Node_Id)
return Project_Node_Id;
pragma Inline (Extended_Project_Of);
! -- Only valid for N_Project_Declaration nodes
function Current_Item_Node
(Node : Project_Node_Id)
*************** package Prj.Tree is
*** 425,430 ****
--- 429,437 ----
To : Variable_Kind);
pragma Inline (Set_Expression_Kind_Of);
+ procedure Set_Is_Extending_All (Node : Project_Node_Id);
+ pragma Inline (Set_Is_Extending_All);
+
procedure Set_First_Variable_Of
(Node : Project_Node_Id;
To : Variable_Node_Id);
*************** package Prj.Tree is
*** 684,689 ****
--- 691,700 ----
-- This flag is significant only for N_Attribute_Declaration and
-- N_Atribute_Reference. It indicates for an associative array
-- attribute, that the index is case insensitive.
+
+ Extending_All : Boolean := False;
+ -- This flag is significant only for N_Project. It indicates that
+ -- the project "extends all" another project.
end record;
Index: sem_ch10.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch10.adb,v
retrieving revision 1.11
diff -u -c -3 -p -r1.11 sem_ch10.adb
*** sem_ch10.adb 4 Nov 2003 12:51:46 -0000 1.11
--- sem_ch10.adb 10 Nov 2003 16:49:44 -0000
*************** package body Sem_Ch10 is
*** 1749,1755 ****
Generate_Reference (Par_Name, Pref);
Pref := Prefix (Pref);
! Par_Name := Scope (Par_Name);
end loop;
if Present (Entity (Pref))
--- 1749,1762 ----
Generate_Reference (Par_Name, Pref);
Pref := Prefix (Pref);
!
! -- If E_Name is the dummy entity for a nonexistent unit,
! -- its scope is set to Standard_Standard, and no attempt
! -- should be made to further unwind scopes.
!
! if Par_Name /= Standard_Standard then
! Par_Name := Scope (Par_Name);
! end if;
end loop;
if Present (Entity (Pref))
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.25
diff -u -c -3 -p -r1.25 sem_ch12.adb
*** sem_ch12.adb 29 Oct 2003 10:26:15 -0000 1.25
--- sem_ch12.adb 10 Nov 2003 16:49:45 -0000
*************** package body Sem_Ch12 is
*** 543,564 ****
-- those nodes that contain global information. At instantiation, the
-- information from the associated node is placed on the new copy, so
-- that name resolution is not repeated.
!
-- Three kinds of source nodes have associated nodes:
!
-- a) those that can reference (denote) entities, that is identifiers,
-- character literals, expanded_names, operator symbols, operators,
-- and attribute reference nodes. These nodes have an Entity field
-- and are the set of nodes that are in N_Has_Entity.
!
-- b) aggregates (N_Aggregate and N_Extension_Aggregate)
!
-- c) selected components (N_Selected_Component)
!
-- For the first class, the associated node preserves the entity if it is
! -- global. If the generic contains nested instantiations, the associated_
-- node itself has been recopied, and a chain of them must be followed.
!
-- For aggregates, the associated node allows retrieval of the type, which
-- may otherwise not appear in the generic. The view of this type may be
-- different between generic and instantiation, and the full view can be
--- 543,564 ----
-- those nodes that contain global information. At instantiation, the
-- information from the associated node is placed on the new copy, so
-- that name resolution is not repeated.
! --
-- Three kinds of source nodes have associated nodes:
! --
-- a) those that can reference (denote) entities, that is identifiers,
-- character literals, expanded_names, operator symbols, operators,
-- and attribute reference nodes. These nodes have an Entity field
-- and are the set of nodes that are in N_Has_Entity.
! --
-- b) aggregates (N_Aggregate and N_Extension_Aggregate)
! --
-- c) selected components (N_Selected_Component)
! --
-- For the first class, the associated node preserves the entity if it is
! -- global. If the generic contains nested instantiations, the associated
-- node itself has been recopied, and a chain of them must be followed.
! --
-- For aggregates, the associated node allows retrieval of the type, which
-- may otherwise not appear in the generic. The view of this type may be
-- different between generic and instantiation, and the full view can be
*************** package body Sem_Ch12 is
*** 566,579 ****
-- type extensions, the same view exchange may have to be performed for
-- some of the ancestor types, if their view is private at the point of
-- instantiation.
!
-- Nodes that are selected components in the parse tree may be rewritten
-- as expanded names after resolution, and must be treated as potential
-- entity holders. which is why they also have an Associated_Node.
!
-- Nodes that do not come from source, such as freeze nodes, do not appear
-- in the generic tree, and need not have an associated node.
!
-- The associated node is stored in the Associated_Node field. Note that
-- this field overlaps Entity, which is fine, because the whole point is
-- that we don't need or want the normal Entity field in this situation.
--- 566,579 ----
-- type extensions, the same view exchange may have to be performed for
-- some of the ancestor types, if their view is private at the point of
-- instantiation.
! --
-- Nodes that are selected components in the parse tree may be rewritten
-- as expanded names after resolution, and must be treated as potential
-- entity holders. which is why they also have an Associated_Node.
! --
-- Nodes that do not come from source, such as freeze nodes, do not appear
-- in the generic tree, and need not have an associated node.
! --
-- The associated node is stored in the Associated_Node field. Note that
-- this field overlaps Entity, which is fine, because the whole point is
-- that we don't need or want the normal Entity field in this situation.
Index: sem_ch13.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch13.adb,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 sem_ch13.adb
*** sem_ch13.adb 21 Oct 2003 13:42:19 -0000 1.9
--- sem_ch13.adb 10 Nov 2003 16:49:45 -0000
*************** package body Sem_Ch13 is
*** 2153,2181 ****
CC, Rectype);
end if;
- -- Test for large object that is not on a storage unit
- -- boundary, defined as a large packed array not
- -- represented by a modular type, or an object for
- -- which a size of greater than 64 bits is specified.
-
- if Fbit mod SSU /= 0 then
- if (Is_Packed_Array_Type (Etype (Comp))
- and then Is_Array_Type
- (Packed_Array_Type (Etype (Comp))))
- or else Esize (Etype (Comp)) > Max_Unaligned_Field
- then
- if SSU = 8 then
- Error_Msg_N
- ("large component must be on byte boundary",
- First_Bit (CC));
- else
- Error_Msg_N
- ("large component must be on word boundary",
- First_Bit (CC));
- end if;
- end if;
- end if;
-
-- This information is also set in the
-- corresponding component of the base type,
-- found by accessing the Original_Record_Component
--- 2153,2158 ----
*************** package body Sem_Ch13 is
*** 2602,2607 ****
--- 2579,2587 ----
--------------------------
procedure Check_Expr_Constants (Nod : Node_Id) is
+ Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent);
+ Ent : Entity_Id := Empty;
+
begin
if Nkind (Nod) in N_Has_Etype
and then Etype (Nod) = Any_Type
*************** package body Sem_Ch13 is
*** 2614,2619 ****
--- 2594,2600 ----
return;
when N_Identifier | N_Expanded_Name =>
+ Ent := Entity (Nod);
-- We need to look at the original node if it is different
-- from the node, since we may have rewritten things and
*************** package body Sem_Ch13 is
*** 2627,2711 ****
-- is not constant, even if the constituents might be
-- acceptable, as in A'Address + offset.
! if Ekind (Entity (Nod)) = E_Variable
! and then Nkind (Declaration_Node (Entity (Nod)))
= N_Object_Declaration
and then
! No (Expression (Declaration_Node (Entity (Nod))))
then
Error_Msg_NE
("invalid address clause for initialized object &!",
Nod, U_Ent);
end if;
return;
end if;
-- Otherwise look at the identifier and see if it is OK.
! declare
! Ent : constant Entity_Id := Entity (Nod);
! Loc_Ent : constant Source_Ptr := Sloc (Ent);
! Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent);
!
! begin
! if Ekind (Ent) = E_Named_Integer
! or else
! Ekind (Ent) = E_Named_Real
! or else
! Is_Type (Ent)
! then
return;
! elsif
! Ekind (Ent) = E_Constant
! or else
! Ekind (Ent) = E_In_Parameter
! then
! -- This is the case where we must have Ent defined
! -- before U_Ent. Clearly if they are in different
! -- units this requirement is met since the unit
! -- containing Ent is already processed.
!
! if not In_Same_Source_Unit (Ent, U_Ent) then
! return;
!
! -- Otherwise location of Ent must be before the
! -- location of U_Ent, that's what prior defined means.
!
! elsif Loc_Ent < Loc_U_Ent then
! return;
!
! else
! Error_Msg_NE
! ("invalid address clause for initialized object &!",
! Nod, U_Ent);
! Error_Msg_Name_1 := Chars (Ent);
! Error_Msg_Name_2 := Chars (U_Ent);
! Error_Msg_N
! ("\% must be defined before % ('R'M 13.1(22))!",
! Nod);
! end if;
! elsif Nkind (Original_Node (Nod)) = N_Function_Call then
! Check_Expr_Constants (Original_Node (Nod));
else
Error_Msg_NE
("invalid address clause for initialized object &!",
Nod, U_Ent);
! if Comes_From_Source (Ent) then
! Error_Msg_Name_1 := Chars (Ent);
! Error_Msg_N
! ("\reference to variable% not allowed"
! & " ('R'M 13.1(22))!", Nod);
! else
! Error_Msg_N
! ("non-static expression not allowed"
! & " ('R'M 13.1(22))!", Nod);
! end if;
end if;
! end;
when N_Integer_Literal |
N_Real_Literal |
--- 2608,2699 ----
-- is not constant, even if the constituents might be
-- acceptable, as in A'Address + offset.
! if Ekind (Ent) = E_Variable
! and then Nkind (Declaration_Node (Ent))
= N_Object_Declaration
and then
! No (Expression (Declaration_Node (Ent)))
! then
! Error_Msg_NE
! ("invalid address clause for initialized object &!",
! Nod, U_Ent);
!
! -- If entity is constant, it may be the result of expanding
! -- a check. We must verify that its declaration appears
! -- before the object in question, else we also reject the
! -- address clause.
!
! elsif Ekind (Ent) = E_Constant
! and then In_Same_Source_Unit (Ent, U_Ent)
! and then Sloc (Ent) > Loc_U_Ent
then
Error_Msg_NE
("invalid address clause for initialized object &!",
Nod, U_Ent);
end if;
+
return;
end if;
-- Otherwise look at the identifier and see if it is OK.
! if Ekind (Ent) = E_Named_Integer
! or else
! Ekind (Ent) = E_Named_Real
! or else
! Is_Type (Ent)
! then
! return;
!
! elsif
! Ekind (Ent) = E_Constant
! or else
! Ekind (Ent) = E_In_Parameter
! then
! -- This is the case where we must have Ent defined
! -- before U_Ent. Clearly if they are in different
! -- units this requirement is met since the unit
! -- containing Ent is already processed.
!
! if not In_Same_Source_Unit (Ent, U_Ent) then
return;
! -- Otherwise location of Ent must be before the
! -- location of U_Ent, that's what prior defined means.
! elsif Sloc (Ent) < Loc_U_Ent then
! return;
else
Error_Msg_NE
("invalid address clause for initialized object &!",
Nod, U_Ent);
+ Error_Msg_Name_1 := Chars (Ent);
+ Error_Msg_Name_2 := Chars (U_Ent);
+ Error_Msg_N
+ ("\% must be defined before % ('R'M 13.1(22))!",
+ Nod);
+ end if;
! elsif Nkind (Original_Node (Nod)) = N_Function_Call then
! Check_Expr_Constants (Original_Node (Nod));
!
! else
! Error_Msg_NE
! ("invalid address clause for initialized object &!",
! Nod, U_Ent);
!
! if Comes_From_Source (Ent) then
! Error_Msg_Name_1 := Chars (Ent);
! Error_Msg_N
! ("\reference to variable% not allowed"
! & " ('R'M 13.1(22))!", Nod);
! else
! Error_Msg_N
! ("non-static expression not allowed"
! & " ('R'M 13.1(22))!", Nod);
end if;
! end if;
when N_Integer_Literal |
N_Real_Literal |
Index: sem_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch5.adb,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 sem_ch5.adb
*** sem_ch5.adb 21 Oct 2003 13:42:19 -0000 1.9
--- sem_ch5.adb 10 Nov 2003 16:49:45 -0000
*************** with Exp_Util; use Exp_Util;
*** 33,38 ****
--- 33,39 ----
with Freeze; use Freeze;
with Lib.Xref; use Lib.Xref;
with Nlists; use Nlists;
+ with Nmake; use Nmake;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Case; use Sem_Case;
*************** package body Sem_Ch5 is
*** 1002,1008 ****
--- 1003,1066 ----
-- Analyze_Iteration_Scheme --
------------------------------
+
procedure Analyze_Iteration_Scheme (N : Node_Id) is
+ procedure Check_Controlled_Array_Attribute (DS : Node_Id);
+ -- If the bounds are given by a 'Range reference on a function call
+ -- that returns a controlled array, introduce an explicit declaration
+ -- to capture the bounds, so that the function result can be finalized
+ -- in timely fashion.
+
+ --------------------------------------
+ -- Check_Controlled_Array_Attribute --
+ --------------------------------------
+
+ procedure Check_Controlled_Array_Attribute (DS : Node_Id) is
+ begin
+ if Nkind (DS) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (DS))
+ and then Ekind (Entity (Prefix (DS))) = E_Function
+ and then Is_Array_Type (Etype (Entity (Prefix (DS))))
+ and then
+ Is_Controlled (
+ Component_Type (Etype (Entity (Prefix (DS)))))
+ and then Expander_Active
+ then
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Arr : constant Entity_Id :=
+ Etype (Entity (Prefix (DS)));
+ Indx : constant Entity_Id :=
+ Base_Type (Etype (First_Index (Arr)));
+ Subt : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('S'));
+ Decl : Node_Id;
+
+ begin
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Subt,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (Indx, Loc),
+ Constraint =>
+ Make_Range_Constraint (Loc,
+ Relocate_Node (DS))));
+ Insert_Before (Parent (N), Decl);
+ Analyze (Decl);
+
+ Rewrite (DS,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Subt, Loc),
+ Attribute_Name => Attribute_Name (DS)));
+ Analyze (DS);
+ end;
+ end if;
+ end Check_Controlled_Array_Attribute;
+
+ -- Start of processing for Analyze_Iteration_Scheme
+
begin
-- For an infinite loop, there is no iteration scheme
*************** package body Sem_Ch5 is
*** 1080,1085 ****
--- 1138,1144 ----
Set_Etype (DS, Any_Type);
end if;
+ Check_Controlled_Array_Attribute (DS);
Make_Index (DS, LP);
Set_Ekind (Id, E_Loop_Parameter);
Index: sem_ch8.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch8.adb,v
retrieving revision 1.11
diff -u -c -3 -p -r1.11 sem_ch8.adb
*** sem_ch8.adb 29 Oct 2003 10:26:15 -0000 1.11
--- sem_ch8.adb 10 Nov 2003 16:49:45 -0000
*************** package body Sem_Ch8 is
*** 4060,4065 ****
--- 4060,4074 ----
Error_Msg_N (
"invalid prefix in selected component&", P);
+ if Is_Access_Type (P_Type)
+ and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type
+ then
+ Error_Msg_Node_2 := Selector_Name (N);
+ Error_Msg_NE (
+ "\incomplete type& has no visible component&", P,
+ Designated_Type (P_Type));
+ end if;
+
else
Error_Msg_N (
"invalid prefix in selected component", P);
Index: s-fileio.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-fileio.adb,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 s-fileio.adb
*** s-fileio.adb 21 Oct 2003 13:42:14 -0000 1.6
--- s-fileio.adb 10 Nov 2003 16:49:45 -0000
*************** package body System.File_IO is
*** 812,817 ****
--- 812,821 ----
-- Normal case of non-null name given
else
+ if Name'Length > Namelen then
+ raise Name_Error;
+ end if;
+
Namestr (1 .. Name'Length) := Name;
Namestr (Name'Length + 1) := ASCII.NUL;
end if;
Index: sinfo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.adb,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 sinfo.adb
*** sinfo.adb 21 Oct 2003 13:42:22 -0000 1.8
--- sinfo.adb 10 Nov 2003 16:49:45 -0000
*************** package body Sinfo is
*** 930,935 ****
--- 930,944 ----
return Node4 (N);
end Entity;
+ function Entity_Or_Associated_Node
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Has_Entity
+ or else NT (N).Nkind = N_Freeze_Entity);
+ return Node4 (N);
+ end Entity_Or_Associated_Node;
+
function Entry_Body_Formal_Part
(N : Node_Id) return Node_Id is
begin
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.12
diff -u -c -3 -p -r1.12 sinfo.ads
*** sinfo.ads 29 Oct 2003 10:26:15 -0000 1.12
--- sinfo.ads 10 Nov 2003 16:49:46 -0000
*************** package Sinfo is
*** 393,399 ****
-- abbreviations are used:
-- Note: the utility program that creates the Treeprs spec (in the file
! -- treeprs.ads) knows about the special fields here, so it must be
-- modified if any change is made to these fields.
-- "plus fields for binary operator"
--- 393,399 ----
-- abbreviations are used:
-- Note: the utility program that creates the Treeprs spec (in the file
! -- xtreeprs.adb) knows about the special fields here, so it must be
-- modified if any change is made to these fields.
-- "plus fields for binary operator"
*************** package Sinfo is
*** 567,580 ****
-- Associated_Node (Node4-Sem)
-- Present in nodes that can denote an entity: identifiers, character
! -- literals, operator symbols, expanded names, operator nodes and
-- attribute reference nodes (all these nodes have an Entity field).
-- This field is also present in N_Aggregate, N_Selected_Component,
! -- and N_Extension_Aggregate nodes. This field is used during generic
! -- processing to relate nodes in the original template to nodes in the
! -- generic copy. It overlaps the Entity field, and is used to capture
! -- global references in the analyzed copy and place them in the instance.
! -- See description in Sem_Ch12 for further details on this usage.
-- At_End_Proc (Node1)
-- This field is present in an N_Handled_Sequence_Of_Statements node.
--- 567,584 ----
-- Associated_Node (Node4-Sem)
-- Present in nodes that can denote an entity: identifiers, character
! -- literals, operator symbols, expanded names, operator nodes, and
-- attribute reference nodes (all these nodes have an Entity field).
-- This field is also present in N_Aggregate, N_Selected_Component,
! -- and N_Extension_Aggregate nodes. This field is used in generic
! -- processing to create links between the generic template and the
! -- generic copy. See Sem_Ch12.Get_Associated_Node for full details.
! -- Note that this field overlaps Entity, which is fine, since, as
! -- explained in Sem_Ch12, the normal function of Entity is not
! -- required at the point where the Associated_Node is set. Note
! -- also, that in generic templates, this means that the Entity field
! -- does not necessarily point to an Entity. Since the back end is
! -- expected to ignore generic templates, this is harmless.
-- At_End_Proc (Node1)
-- This field is present in an N_Handled_Sequence_Of_Statements node.
*************** package Sinfo is
*** 861,868 ****
-- incorrect (e.g. during overload resolution, Entity is initially
-- set to the first possible correct interpretation, and then later
-- modified if necessary to contain the correct value after resolution).
! -- Note that Associated_Node overlays this field during the processing
! -- of generics. See Sem_Ch12 for further details.
-- Etype (Node5-Sem)
-- Appears in all expression nodes, all direct names, and all
--- 865,880 ----
-- incorrect (e.g. during overload resolution, Entity is initially
-- set to the first possible correct interpretation, and then later
-- modified if necessary to contain the correct value after resolution).
! -- Note that this field overlaps Associated_Node, which is used during
! -- generic processing (see Sem_Ch12 for details). Note also that in
! -- generic templates, this means that the Entity field does not always
! -- point to an Entity. Since the back end is expected to ignore
! -- generic templates, this is harmless.
!
! -- Entity_Or_Associated_Node (Node4-Sem)
! -- A synonym for both Entity and Asasociated_Node. Used by convention
! -- in the code when referencing this field in cases where it is not
! -- known whether the field contains an Entity or an Associated_Node.
-- Etype (Node5-Sem)
-- Appears in all expression nodes, all direct names, and all
*************** package Sinfo is
*** 7107,7112 ****
--- 7119,7127 ----
function Entity
(N : Node_Id) return Node_Id; -- Node4
+ function Entity_Or_Associated_Node
+ (N : Node_Id) return Node_Id; -- Node4
+
function Entry_Body_Formal_Part
(N : Node_Id) return Node_Id; -- Node5
*************** package Sinfo is
*** 8491,8496 ****
--- 8506,8512 ----
pragma Inline (End_Label);
pragma Inline (End_Span);
pragma Inline (Entity);
+ pragma Inline (Entity_Or_Associated_Node);
pragma Inline (Entry_Body_Formal_Part);
pragma Inline (Entry_Call_Alternative);
pragma Inline (Entry_Call_Statement);
Index: sprint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sprint.adb,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 sprint.adb
*** sprint.adb 29 Oct 2003 10:26:15 -0000 1.8
--- sprint.adb 10 Nov 2003 16:49:46 -0000
*************** package body Sprint is
*** 61,67 ****
Dump_Generated_Only : Boolean;
-- Set True if the -gnatG (dump generated tree) debug flag is set
! -- or for Print_Generated_Code (-gnatG) or Dump_Gnerated_Code (-gnatD).
Dump_Freeze_Null : Boolean;
-- Set True if freeze nodes and non-source null statements output
--- 61,67 ----
Dump_Generated_Only : Boolean;
-- Set True if the -gnatG (dump generated tree) debug flag is set
! -- or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD).
Dump_Freeze_Null : Boolean;
-- Set True if freeze nodes and non-source null statements output
*************** package body Sprint is
*** 2782,2791 ****
then
Write_Id (Entity (Parent (N)));
! -- For any other kind of node with an associated entity, output it.
elsif Nkind (N) in N_Has_Entity
! and then Present (Entity (N))
then
Write_Id (Entity (N));
--- 2782,2792 ----
then
Write_Id (Entity (Parent (N)));
! -- For any other node with an associated entity, output it
elsif Nkind (N) in N_Has_Entity
! and then Present (Entity_Or_Associated_Node (N))
! and then Nkind (Entity_Or_Associated_Node (N)) in N_Entity
then
Write_Id (Entity (N));
Index: s-thread.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-thread.adb,v
retrieving revision 1.2
diff -u -c -3 -p -r1.2 s-thread.adb
*** s-thread.adb 4 Nov 2003 12:51:46 -0000 1.2
--- s-thread.adb 10 Nov 2003 16:49:46 -0000
***************
*** 33,50 ****
-- This is the VxWorks/Cert version of this package
with Unchecked_Conversion;
package body System.Threads is
Current_ATSD : aliased System.Address := System.Null_Address;
pragma Export (C, Current_ATSD, "__gnat_current_atsd");
function From_Address is
new Unchecked_Conversion (Address, ATSD_Access);
-
-
-----------------------
-- Get_Current_Excep --
-----------------------
--- 33,53 ----
-- This is the VxWorks/Cert version of this package
+ with System.Init;
+ with System.Secondary_Stack;
+
with Unchecked_Conversion;
package body System.Threads is
+ package SSS renames System.Secondary_Stack;
+
Current_ATSD : aliased System.Address := System.Null_Address;
pragma Export (C, Current_ATSD, "__gnat_current_atsd");
function From_Address is
new Unchecked_Conversion (Address, ATSD_Access);
-----------------------
-- Get_Current_Excep --
-----------------------
*************** package body System.Threads is
*** 109,119 ****
Sec_Stack_Size : Natural;
Process_ATSD_Address : System.Address)
is
! pragma Unreferenced (Sec_Stack_Address);
! pragma Unreferenced (Sec_Stack_Size);
! pragma Unreferenced (Process_ATSD_Address);
begin
! null;
end Thread_Body_Enter;
----------------------------------
--- 112,129 ----
Sec_Stack_Size : Natural;
Process_ATSD_Address : System.Address)
is
! -- Current_ATSD must already be a taskVar of taskIdSelf.
! -- No assertion because taskVarGet is not available on VxWorks/CERT
!
! TSD : ATSD_Access := From_Address (Process_ATSD_Address);
!
begin
! TSD.Sec_Stack_Addr := Sec_Stack_Address;
! SSS.SS_Init (TSD.Sec_Stack_Addr, Sec_Stack_Size);
! Current_ATSD := Process_ATSD_Address;
!
! System.Init.Install_Handler;
! System.Init.Init_Float;
end Thread_Body_Enter;
----------------------------------
*************** package body System.Threads is
*** 125,130 ****
--- 135,141 ----
is
pragma Unreferenced (EO);
begin
+ -- No action for this target
null;
end Thread_Body_Exceptional_Exit;
*************** package body System.Threads is
*** 134,139 ****
--- 145,151 ----
procedure Thread_Body_Leave is
begin
+ -- No action for this target
null;
end Thread_Body_Leave;
Index: s-thread.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-thread.ads,v
retrieving revision 1.2
diff -u -c -3 -p -r1.2 s-thread.ads
*** s-thread.ads 4 Nov 2003 12:51:46 -0000 1.2
--- s-thread.ads 10 Nov 2003 16:49:46 -0000
***************
*** 34,39 ****
--- 34,42 ----
-- This package provides facilities to register a thread to the runtime,
-- and allocate its task specific datas.
+ -- pragma Thread_Body is currently supported for:
+ -- VxWorks AE653 with the restricted / cert runtime
+
with Ada.Exceptions;
package System.Threads is
Index: switch-c.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/switch-c.adb,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 switch-c.adb
*** switch-c.adb 29 Oct 2003 10:26:16 -0000 1.6
--- switch-c.adb 10 Nov 2003 16:49:46 -0000
*************** package body Switch.C is
*** 96,103 ****
when False =>
! -- There are only two front-end switches that
! -- do not start with -gnat, namely -I and --RTS
if Switch_Chars (Ptr) = 'I' then
Store_Switch := False;
--- 96,103 ----
when False =>
! -- There are few front-end switches that
! -- do not start with -gnat: -I, --RTS, -nostdlib
if Switch_Chars (Ptr) = 'I' then
Store_Switch := False;
*************** package body Switch.C is
*** 119,124 ****
--- 119,132 ----
Ptr := Max + 1;
+ -- Processing of -nostdlib
+
+ elsif Ptr + 7 = Max
+ and then Switch_Chars (Ptr .. Ptr + 7) = "nostdlib"
+ then
+ Opt.No_Stdlib := True;
+ Ptr := Max + 1;
+
-- Processing of the --RTS switch. --RTS has been modified by
-- gcc and is now of the form -fRTS
*************** package body Switch.C is
*** 636,641 ****
--- 644,655 ----
Ptr := Ptr + 1;
Operating_Mode := Check_Syntax;
+
+ -- Processing for S switch
+
+ when 'S' =>
+ Print_Standard := True;
+ Ptr := Ptr + 1;
-- Processing for t switch
Index: usage.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/usage.adb,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 usage.adb
*** usage.adb 21 Oct 2003 13:42:23 -0000 1.10
--- usage.adb 10 Nov 2003 16:49:46 -0000
*************** begin
*** 277,282 ****
--- 277,287 ----
Write_Switch_Char ("s");
Write_Line ("Syntax check only");
+ -- Lines for -gnatS switch
+
+ Write_Switch_Char ("S");
+ Write_Line ("Print listing of package Standard");
+
-- Lines for -gnatt switch
Write_Switch_Char ("t");
Index: vms_data.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/vms_data.ads,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 vms_data.ads
*** vms_data.ads 21 Oct 2003 13:42:23 -0000 1.1
--- vms_data.ads 10 Nov 2003 16:49:46 -0000
*************** package VMS_Data is
*** 1526,1531 ****
--- 1526,1537 ----
--
-- Do not look in the default directory for source files of the runtime.
+ S_GCC_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
+ "-nostdlib";
+ -- /NOSTD_LIBRARIES
+ --
+ -- Do not look for library files in the system default directory.
+
S_GCC_Opt : aliased constant S := "/OPTIMIZE=" &
"ALL " &
"-O2,!-O0,!-O1,!-O3 " &
*************** package VMS_Data is
*** 2809,2814 ****
--- 2815,2821 ----
S_GCC_Noadc 'Access,
S_GCC_Noload 'Access,
S_GCC_Nostinc 'Access,
+ S_GCC_Nostlib 'Access,
S_GCC_Opt 'Access,
S_GCC_OptX 'Access,
S_GCC_Polling 'Access,
Index: gnatvsn.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatvsn.ads,v
retrieving revision 1.131
diff -u -c -3 -p -r1.131 gnatvsn.ads
*** gnatvsn.ads 24 Oct 2003 14:39:55 -0000 1.131
--- gnatvsn.ads 10 Nov 2003 16:49:46 -0000
*************** package Gnatvsn is
*** 45,56 ****
-- Static string identifying this version, that can be used as an argument
-- to e.g. pragma Ident.
! Gnat_Version_Type : constant String := "FSF ";
! -- GNAT FSF version. This version of GNAT is part of a Free Software
! -- Foundation release of the GNU Compiler Collection (GCC). The binder
! -- will not output informational messages regarding intended use,
! -- and the bug box generated by Comperr will give information on
! -- how to report bugs and list the "no warranty" information.
Ver_Len_Max : constant := 32;
-- Longest possible length for Gnat_Version_String in this or any
--- 45,68 ----
-- Static string identifying this version, that can be used as an argument
-- to e.g. pragma Ident.
! type Gnat_Build_Type is (FSF, Public);
! -- See Get_Gnat_Build_Type below for the meaning of these values.
!
! function Get_Gnat_Build_Type return Gnat_Build_Type;
! -- This function returns one of the following values of Gnat_Build_Type:
! --
! -- FSF
! -- GNAT FSF version. This version of GNAT is part of a Free Software
! -- Foundation release of the GNU Compiler Collection (GCC). The binder
! -- will not output informational messages regarding intended use,
! -- and the bug box generated by Comperr will give information on
! -- how to report bugs and list the "no warranty" information.
! --
! -- Public
! -- GNAT Public version.
! -- The binder will output informational messages, and the bug box
! -- generated by the package Comperr will give appropriate bug
! -- submission instructions.
Ver_Len_Max : constant := 32;
-- Longest possible length for Gnat_Version_String in this or any
Index: gnatvsn.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatvsn.adb,v
retrieving revision 1.3
diff -u -c -3 -p -r1.3 gnatvsn.adb
*** gnatvsn.adb 21 Oct 2003 13:42:08 -0000 1.3
--- gnatvsn.adb 10 Nov 2003 16:49:46 -0000
*************** package body Gnatvsn is
*** 41,46 ****
--- 41,55 ----
pragma Import (C, Version_String, "version_string");
-------------------------
+ -- Get_Gnat_Build_Type --
+ -------------------------
+
+ function Get_Gnat_Build_Type return Gnat_Build_Type is
+ begin
+ return FSF;
+ end Get_Gnat_Build_Type;
+
+ -------------------------
-- Gnat_Version_String --
-------------------------