procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2004-04-19  Arnaud Charlet  <charlet@act-europe.fr>

	* 5isystem.ads: Removed, unused.

	* gnat_rm.texi: Redo 1.13 change.

2004-04-19  Robert Dewar  <dewar@gnat.com>

	* s-stoele.ads: Clean up definition of Storage_Offset (the new
	definition is cleaner, avoids the kludge of explicit Standard operator
	references, and also is consistent with a visible System.Address with
	no visible operations.

	* s-geveop.adb: Add declarations to avoid assumption of visible
	operations on type System.Address (since these might not be available
	if Address is a non-private type for which the operations
	are made abstract).

	* sem_eval.adb: Minor reformatting

	* s-carsi8.ads, s-carun8.ads, s-casi16.ads, s-casi32.ads,
	s-casi64.ads, s-caun16.ads, s-caun32.ads, s-caun64.ads: Minor
	reformatting (new function spec format).

	* s-auxdec.adb, s-carsi8.adb, s-carun8.adb, s-casi16.adb,
	s-casi32.adb, s-casi64.adb, s-caun16.adb, s-caun32.adb,
	s-caun64.adb: Add declarations to avoid assumption of visible
	operations on type System.Address (since these might not be available
	if Address is a non-private type for which the operations are made
	abstract).

	* lib.ads, lib.adb (Synchronize_Serial_Number): New procedure.

	* exp_intr.adb: Minor comment update

	* exp_aggr.adb, exp_attr.adb, exp_ch13.adb: Minor reformatting.

	* 5omastop.adb: Add declarations to avoid assumption of visible
	operations on type System.Address (since these might not be available
	if Address is a non-private type for which the operations
	are made abstract).

2004-04-19  Vincent Celier  <celier@gnat.com>

	* switch-m.adb: (Scan_Make_Switches): Process new switch -eL

	* prj-pars.ads (Parse): New Boolean parameter Process_Languages,
	defaulted to Ada.

	* prj-proc.adb (Process): New Boolean parameter Process_Languages,
	defaulted to Ada.
	Call Check with Process_Languages.
	(Check): New Boolean parameter Process_Languages. Call Recursive_Check
	with Process_Languages.
	(Recursive_Check): New Boolean parameter Process_Languages. Call
	Nmsc.Ada_Check or Nmsc.Other_Languages_Check according to
	Process_Languages.

	* prj-proc.ads (Process): New Boolean parameter Process_Languages,

	* prj-util.ads, prj-util.adb (Executable_Of): New Boolean
	parameter Ada_Main, defaulted to True.
	Check for Ada specific characteristics only when Ada_Main is True.

	* opt.ads: (Follow_Links): New Boolean flag for gnatmake

	* prj.adb: (Project_Empty): Add new Project_Data components.

	* prj.ads: New types and tables for non Ada languages.
	(Project_Data): New components Languages, Impl_Suffixes,
	First_Other_Source, Last_Other_Source, Imported_Directories_Switches,
	Include_Path, Include_Data_Set.

	* prj-env.ads, prj-env.adb: Minor reformatting

	* prj-nmsc.ads, prj-nmsc.adb: (Other_Languages_Check): New procedure
	Put subprograms in alphabetical order

	* prj-pars.adb (Parse): New Boolean parameter Process_Languages,
	defaulted to Ada; Call Prj.Proc.Process with Process_Languages and
	Opt.Follow_Links.

	* mlib-prj.adb: Back out modification in last version, as they are
	incorrect.
	(Build_Library.Check_Libs): Remove useless pragma Warnings (Off)

	* make.adb: (Mains): Moved to package Makeutl
	(Linker_Opts): Moved to package Makeutl
	(Is_External_Assignment): Moved to package Makeutl
	(Test_If_Relative_Path): Moved to package Makeutl
	(Gnatmake): Move sorting of linker options to function
	Makeutl.Linker_Options_Switches.

	* Makefile.in: Add makeutl.o to the object files for gnatmake

	* makeusg.adb: Add line for new switch -eL.

	* gnatls.adb (Image): New function.
	(Output_Unit): If in verbose mode, output the list of restrictions
	specified by pragmas Restrictions.

	* 5bml-tgt.adb, 5vml-tgt.adb (Build_Dynamic_Library): Do not use
	Text_IO.

	* a-calend.adb (Split): Shift the date by multiple of 56 years, if
	needed, to put it in the range 1970 (included) - 2026 (excluded).
	(Time_Of): Do not shift Unix_Min_Year (1970).
	Shift the date by multiple of 56 years, if needed, to put it in the
	range 1970 (included) - 2026 (excluded).

	* adaint.h, adaint.c (__gnat_set_executable): New function.

2004-04-19  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	* trans.c (tree_transform, case N_Subprogram_Body): Temporarily push
	and pop GC context.
	(tree_transform, case N_Procedure_Call): Fix typo in setting TREE_TYPE.
	(tree_transform, case N_Label): Don't set LABEL_STMT_FIRST_IN_EH.
	(tree_transform, case N_Procedure_Call_Statement): Build a tree.
	(tree_transform, case N_Code_Statement): Likewise.
	(gnat_expand_stmt, case LABEL_STMT): Don't look at
	LABEL_STMT_FIRST_IN_EH.
	(gnat_expand_stmt, case ASM_STMT): New case.

	* utils2.c (build_unary_op): Properly set TREE_READONLY of
	UNCONSTRAINED_ARRAY_REF.

	* utils.c (poplevel): Temporarily push/pop GC context around inline
	function expansion.

	* decl.c (maybe_variable): Properly set TREE_READONLY of
	UNCONSTRAINED_ARRAY_REF.
	(make_packable_type): Only reference TYPE_IS_PADDING_P for RECORD_TYPE.

	* ada-tree.def: (ASM_STMT): New.

	* ada-tree.h: (LABEL_STMT_FIRST_IN_EH): Deleted.
	(ASM_STMT_TEMPLATE, ASM_STMT_OUTPUT, ASM_STMT_ORIG_OUT,
	ASM_STMT_INPUT): New.
	(ASM_STMT_CLOBBER): Likewise.

2004-04-19  Thomas Quinot  <quinot@act-europe.fr>

	* a-except.adb, s-parint.ads, s-parint.adb, types.ads, types.h: Use
	general rcheck mechanism to raise Program_Error for E.4(18), instead
	of a custom raiser in System.Partition_Interface.
	Part of general cleanup work before PolyORB integration.

	* snames.ads, snames.adb: Add new runtime library entities and names
	for PolyORB DSA.

	* sem_dist.ads, sem_dist.adb (Get_Subprogram_Id): Move from sem_dist to
	exp_dist.
	(Build_Subprogram_Id): New subprogram provided by exp_dist
	Code reorganisation in preparation for PolyORB integration.

	* exp_dist.ads, exp_dist.adb (Get_Subprogram_Id): Move from sem_dist to
	exp_dist.
	(Build_Subprogram_Id): New subprogram provided by exp_dist

	* sem_ch4.adb (Analyze_One_Call): Fix error message for mismatch in
	actual parameter types for call to dereference of an
	access-to-subprogram type.

	* rtsfind.ads: Add new runtime library entities and names for PolyORB
	DSA.

	* gnatlink.adb (Value): Remove. Use Interfaces.C.Strings.Value
	instead, which has the same behaviour here since we never pass it a
	NULL pointer.

	* link.c (run_path_option, Solaris case): Use -Wl, as for other
	platforms.

	* Makefile.in: adjust object file lists for gnatlink and gnatmake
	to account for new dependency upon Interfaces.C.Strings + link.o
	For x86 FreeBSD, use 86numaux.

	* make.adb, gnatcmd.adb: Linker_Library_Path_Option has been moved up
	from Mlib.Tgt to Mlib.

	* mlib.ads, mlib.adb (Linker_Library_Path_Option): New subprogram, now
	target-independent.

	* mlib-tgt.ads, mlib-tgt.adb (Linker_Library_Path_Option): Remove
	target-specific versions of this subprogram, now implemented as a
	target-independent function in Mlib.

	* 5aml-tgt.adb, 5bml-tgt.adb, 5gml-tgt.adb, 5hml-tgt.adb, 5lml-tgt.adb,
	5sml-tgt.adb, 5vml-tgt.adb, 5zml-tgt.adb, 5wml-tgt.adb
	(Linker_Library_Path_Option): Remove target-specific versions of this
	subprogram, now implemented as a target-independent function in Mlib.

	* atree.adb: (Allocate_Initialize_Node): New subprogram.
	Factors out node table slots allocation.
	(Fix_Parents): New subprogram.
	Encapsulate the pattern of fixing up parent pointers for syntactic
	children of a rewritten node.
	(New_Copy_Tree): Use New_Copy to copy non-entity nodes.
	(Rewrite): Use New_Copy when creating saved copy of original node.
	(Replace): Use Copy_Node to copy nodes.

2004-04-19  Javier Miranda  <miranda@gnat.com>

	* sprint.adb (Sprint_Node_Actual): Give support to the new
	Access_To_Subprogram node available in Access_Definition nodes. In
	addition, give support to the AI-231 node fields: null-exclusion,
	all-present, constant-present.

	* sem_util.ads, sem_util.adb: (Has_Declarations): New subprogram

	* sinfo.ads, sinfo.adb:
	New field Access_To_Subprogram_Definition in Access_Definition nodes

	* sem_ch6.adb (Process_Formals): Move here the code that creates and
	decorates internal subtype declaration corresponding to the
	null-excluding formal. This code was previously in Set_Actual_Subtypes.
	In addition, carry out some code cleanup on this code. In case of
	access to protected subprogram call
	Replace_Anonymous_Access_To_Protected_Subprogram.
	(Set_Actual_Subtypes): Code cleanup.

	* sem_ch8.adb (Analyze_Object_Renaming): Remove un-necessary call to
	Find_Type in case of anonymous access renamings. Add warning in case of
	null-excluding attribute used in anonymous access renaming.

	* sem_ch3.ads (Replace_Anonymous_Access_To_Protected_Subprogram): New
	subprogram

	* sem_ch3.adb (Replace_Anonymous_Access_To_Protected_Subprogram): New
	subprogram.
	(Access_Definition): In case of anonymous access to subprograms call
	the corresponding semantic routine to decorate the node.
	(Access_Subprogram_Declaration): Addition of some comments indicating
	some code that probably should be added here. Detected by comparison
	with the access_definition subprogram.
	(Analyze_Component_Declaration): In case of access to protected
	subprogram call Replace_Anonymous_Access_To_Protected.
	(Array_Type_Declaration): In case of access to protected subprogram call
	Replace_Anonymous_Access_To_Protected_Subprogram.
	(Process_Discriminants): In case of access to protected subprogram call
	Replace_Anonymous_Access_To_Protected_Subprogram.

	* par.adb (P_Access_Definition): New formal that indicates if the
	null-exclusion part was present.
	(P_Access_Type_Definition): New formal that indicates if the caller has
	already parsed the null-excluding part.

	* par-ch3.adb (P_Subtype_Declaration): Code cleanup.
	(P_Identifier_Declarations): Code cleanup and give support to renamings
	of anonymous access to subprogram types.
	(P_Derived_Type_Def_Or_Private_Ext_Decl): Code cleanup.
	(P_Array_Type_Definition): Give support to AI-254.
	(P_Component_Items): Give support to AI-254.
	(P_Access_Definition): New formal that indicates if the header was
	already parsed by the caller.
	(P_Access_Type_Definition): New formal that indicates if the caller has
	already parsed the null-excluding part.

	* par-ch6.adb (P_Formal_Part): Add the null-excluding parameter to the
	call to P_Access_Definition.

2004-04-19  Geert Bosch  <bosch@gnat.com>

	* checks.adb (Apply_Float_Conversion_Check): New procedure to implement
	the delicate semantics of floating-point to integer conversion.
	(Apply_Type_Conversion_Checks): Use Apply_Float_Conversion_Check.

	* eval_fat.adb (Machine_Mantissa): Moved to spec.
	(Machine_Radix): New function.

	* eval_fat.ads (Machine_Mantissa): Moved from body for use in
	conversion checks.
	(Machine_Radix): New function also for use in conversion checks.

2004-04-19  Ed Schonberg  <schonberg@gnat.com>

	* par-prag.adb (Source_File_Name_Project): Fix typo in error message.

	* exp_ch9.adb (Expand_Access_Protected_Subprogram_Type): Call analyze
	to decorate the access-to-protected subprogram and the equivalent type.

	* checks.adb (Null_Exclusion_Static_Checks): Code cleanup. Give support
	to anonymous access to subprogram types.

	* exp_ch4.adb (Expand_N_In): Preserve Static flag before
	constant-folding, for legality checks in contexts that require an RM
	static expression.

	* exp_ch6.adb (Expand_N_Function_Call): If call may generate large
	temporary but stack checking is not enabled, increment serial number
	to so that symbol generation is consistent with and without stack
	checking.

	* exp_util.ads, exp_util.adb (May_Generate_Large_Temp): Predicate is
	independent on whether stack checking is enabled, caller must check
	the corresponding flag.

	* sem_ch3.adb (Constrain_Index): Index bounds given by attributes need
	range checks.
	(Build_Derived_Concurrent_Type): Inherit Is_Constrained flag from
	parent if it has discriminants.
	(Build_Derived_Private_Type): Constructed full view does
	not come from source.
	(Process_Discriminants): Default discriminants on a tagged type are
	legal if this is the internal completion of a private untagged
	derivation.

	* sem_ch6.adb (Set_Actual_Subtypes): The generated declaration needs
	no constraint checks, because it corresponds to an existing object.

	* sem_prag.adb (Process_Convention): Pragma applies
	only to subprograms in the same declarative part, i.e. the same unit,
	not the same scope.

	* sem_res.adb (Valid_Conversion): In an instance or inlined body,
	ignore type mismatch on a numeric conversion if expression comes from
	expansion.

2004-04-19  Sergey Rybin  <rybin@act-europe.fr>

	* sem_elim.adb (Process_Eliminate_Pragma): Remove the processing for
	Homonym_Number parameter, add processing for Source_Location parameter
	corresponding.
	(Check_Eliminated): Remove the check for homonym numbers, add the check
	for source location traces.

	* sem_elim.ads (Process_Eliminate_Pragma): Replace Arg_Homonym_Number
	with Arg_Source_Location corresponding to the changes in the format of
	the pragma.

	* sem_prag.adb: (Analyze_Pragma): Changes in the processing of
	Eliminate pragma corresponding to the changes in the format of the
	pragma: Homonym_Number is replaced with Source_Location, two ways of
	distinguishing homonyms are mutially-exclusive.

2004-04-19  Joel Brobecker  <brobecker@gnat.com>

	* get_targ.ads (Get_No_Dollar_In_Label): Remove.

	* exp_dbug.adb (Output_Homonym_Numbers_Suffix): Remove use of
	No_Dollar_In_Label, no longer necessary, as it is always True.
	(Strip_Suffixes): Likewise.

2004-04-19  Gary Dismukes  <dismukes@gnat.com>

	* s-stalib.ads (type Exception_Code): Use Integer'Size for exponent of
	modulus for compatibility with size clause on targets with 16-bit
	Integer.

	* layout.adb (Discrimify): In the case of private types, set Vtyp to
	full type to fix type mismatches on calls to size functions for
	discriminant-dependent array components.

2004-04-19  Jerome Guitton  <guitton@act-europe.fr>

	* Makefile.in (gnatlib-zcx): New target, for building a ZCX run-time
	lib.

2004-04-19  Pascal Obry  <obry@gnat.com>

	* mdll-utl.adb (Locate): New version is idempotent.

From-SVN: r80856
This commit is contained in:
Arnaud Charlet 2004-04-19 17:20:16 +02:00
parent 10b5935eb2
commit 7324bf49ce
118 changed files with 5217 additions and 3031 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
gcc/ada/5aml-tgt.adb
View file

@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -341,15 +341,6 @@ package body MLib.Tgt is
end if;
end Library_File_Name_For;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
function Linker_Library_Path_Option return String_Access is
begin
return new String'("-Wl,-rpath,");
end Linker_Library_Path_Option;
----------------
-- Object_Ext --
----------------

37
gcc/ada/5bml-tgt.adb
View file

@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2003, Ada Core Technologies, Inc. --
-- Copyright (C) 2003-2004, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -31,14 +31,16 @@
-- This is the AIX version of the body.
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with MLib.Fil;
with MLib.Utl;
with Namet; use Namet;
with Osint; use Osint;
with Namet; use Namet;
with Osint; use Osint;
with Opt;
with Output; use Output;
with Output; use Output;
with Prj.Com;
with Prj.Util; use Prj.Util;
package body MLib.Tgt is
@ -172,14 +174,13 @@ package body MLib.Tgt is
if Thread_Options = null then
declare
File : Ada.Text_IO.File_Type;
File : Text_File;
Line : String (1 .. 100);
Last : Natural;
begin
Open
(File, In_File,
Include_Dir_Default_Prefix & "/s-osinte.ads");
(File, Include_Dir_Default_Prefix & "/s-osinte.ads");
while not End_Of_File (File) loop
Get_Line (File, Line, Last);
@ -297,10 +298,12 @@ package body MLib.Tgt is
else
declare
Lib_Dir : constant String :=
Get_Name_String (Projects.Table (Project).Library_Dir);
Lib_Dir : constant String :=
Get_Name_String
(Projects.Table (Project).Library_Dir);
Lib_Name : constant String :=
Get_Name_String (Projects.Table (Project).Library_Name);
Get_Name_String
(Projects.Table (Project).Library_Name);
begin
if Projects.Table (Project).Library_Kind = Static then
@ -349,18 +352,6 @@ package body MLib.Tgt is
end if;
end Library_File_Name_For;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
function Linker_Library_Path_Option return String_Access is
begin
-- On AIX, any path specify with an -L switch is automatically added
-- to the library path. So, nothing is needed here.
return null;
end Linker_Library_Path_Option;
----------------
-- Object_Ext --
----------------

11
gcc/ada/5gml-tgt.adb
View file

@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2003, Ada Core Technologies, Inc. --
-- Copyright (C) 2003-2004, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -324,15 +324,6 @@ package body MLib.Tgt is
end if;
end Library_File_Name_For;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
function Linker_Library_Path_Option return String_Access is
begin
return new String'("-Wl,-rpath,");
end Linker_Library_Path_Option;
----------------
-- Object_Ext --
----------------

11
gcc/ada/5hml-tgt.adb
View file

@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2003, Ada Core Technologies, Inc. --
-- Copyright (C) 2003-2004, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -329,15 +329,6 @@ package body MLib.Tgt is
end if;
end Library_File_Name_For;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
function Linker_Library_Path_Option return String_Access is
begin
return new String'("-Wl,+b,");
end Linker_Library_Path_Option;
----------------
-- Object_Ext --
----------------

166
gcc/ada/5isystem.ads
View file

@ -1,166 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (VxWorks/LEVEL B Version PPC) --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Level B certifiable VxWorks version
pragma Restrictions (No_Finalization);
pragma Restrictions (No_Exception_Registration);
pragma Restrictions (No_Abort_Statements);
pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
package System is
pragma Pure (System);
-- Note that we take advantage of the implementation permission to
-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
type Name is (SYSTEM_NAME_GNAT);
System_Name : constant Name := SYSTEM_NAME_GNAT;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Long_Integer'First;
Max_Int : constant := Long_Long_Integer'Last;
Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
Max_Nonbinary_Modulus : constant := Integer'Last;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0 / 60.0;
-- Storage-related Declarations
type Address is private;
Null_Address : constant Address;
Storage_Unit : constant := 8;
Word_Size : constant := 32;
Memory_Size : constant := 2 ** 32;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
Default_Bit_Order : constant Bit_Order := High_Order_First;
-- Priority-related Declarations (RM D.1)
-- 256 is reserved for the VxWorks kernel
-- 248 - 255 correspond to hardware interrupt levels 0 .. 7
-- 247 is a catchall default "interrupt" priority for signals,
-- allowing higher priority than normal tasks, but lower than
-- hardware priority levels. Protected Object ceilings can
-- override these values.
-- 246 is used by the Interrupt_Manager task
Max_Priority : constant Positive := 245;
Max_Interrupt_Priority : constant Positive := 255;
subtype Any_Priority is Integer range 0 .. 255;
subtype Priority is Any_Priority range 0 .. 245;
subtype Interrupt_Priority is Any_Priority range 246 .. 255;
Default_Priority : constant Priority := 122;
private
type Address is mod Memory_Size;
Null_Address : constant Address := 0;
--------------------------------------
-- System Implementation Parameters --
--------------------------------------
-- These parameters provide information about the target that is used
-- by the compiler. They are in the private part of System, where they
-- can be accessed using the special circuitry in the Targparm unit
-- whose source should be consulted for more detailed descriptions
-- of the individual switch values.
AAMP : constant Boolean := False;
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := False;
Configurable_Run_Time : constant Boolean := True;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := True;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
Support_64_Bit_Divides : constant Boolean := True;
Support_Aggregates : constant Boolean := True;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := True;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := False;
-- Obsolete entries, to be removed eventually (bootstrap issues!)
High_Integrity_Mode : constant Boolean := True;
Long_Shifts_Inlined : constant Boolean := False;
end System;

11
gcc/ada/5lml-tgt.adb
View file

@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2003, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2004, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -326,15 +326,6 @@ package body MLib.Tgt is
end if;
end Library_File_Name_For;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
function Linker_Library_Path_Option return String_Access is
begin
return new String'("-Wl,-rpath,");
end Linker_Library_Path_Option;
----------------
-- Object_Ext --
----------------

8
gcc/ada/5omastop.adb
View file

@ -7,7 +7,7 @@
-- B o d y --
-- (Version for x86) --
-- --
-- Copyright (C) 1999-2002 Ada Core Technologies, Inc. --
-- Copyright (C) 1999-2004 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -43,6 +43,12 @@ with System.Memory;
package body System.Machine_State_Operations is
function "+" (Left, Right : Address) return Address;
pragma Import (Intrinsic, "+");
-- Provide addition operation on type Address (this may not be directly
-- available if type System.Address is non-private and the operations on
-- the type are made abstract to hide them from public users of System).
use System.Exceptions;
type Uns8 is mod 2 ** 8;

11
gcc/ada/5sml-tgt.adb
View file

@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -323,15 +323,6 @@ package body MLib.Tgt is
end if;
end Library_File_Name_For;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
function Linker_Library_Path_Option return String_Access is
begin
return new String'("-Wl,-R,");
end Linker_Library_Path_Option;
----------------
-- Object_Ext --
----------------

57
gcc/ada/5vml-tgt.adb
View file

@ -28,9 +28,9 @@
-- This is the VMS version of the body
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with MLib.Fil;
with MLib.Utl;
@ -289,14 +289,16 @@ package body MLib.Tgt is
if Auto_Init then
declare
Macro_File_Name : constant String := Lib_Filename & "$init.asm";
Macro_File : Ada.Text_IO.File_Type;
Macro_File : File_Descriptor;
Init_Proc : String := Lib_Filename & "INIT";
Popen_Result : System.Address;
Pclose_Result : Integer;
Len : Natural;
OK : Boolean := True;
Command : constant String :=
Macro_Name & " " & Macro_File_Name & ASCII.NUL;
-- The command to invoke the macro-assembler on the generated
-- The command to invoke the assembler on the generated auto-init
-- assembly file.
Mode : constant String := "r" & ASCII.NUL;
@ -311,22 +313,42 @@ package body MLib.Tgt is
Write_Line ("""");
end if;
-- Create and write the auto-init assembly file
declare
First_Line : constant String :=
ASCII.HT & ".section LIB$INITIALIZE,GBL,NOWRT" &
ASCII.LF;
Second_Line : constant String :=
ASCII.HT & ".long " & Init_Proc & ASCII.LF;
-- First and second lines of the auto-init assembly file
begin
Create (Macro_File, Out_File, Macro_File_Name);
Macro_File := Create_File (Macro_File_Name, Text);
OK := Macro_File /= Invalid_FD;
Put_Line
(Macro_File,
ASCII.HT & ".section LIB$INITIALIZE,GBL,NOWRT");
Put_Line
(Macro_File,
ASCII.HT & ".long " & Init_Proc);
if OK then
Len := Write
(Macro_File, First_Line (First_Line'First)'Address,
First_Line'Length);
OK := Len = First_Line'Length;
end if;
Close (Macro_File);
if OK then
Len := Write
(Macro_File, Second_Line (Second_Line'First)'Address,
Second_Line'Length);
OK := Len = Second_Line'Length;
end if;
exception
when others =>
if OK then
Close (Macro_File, OK);
end if;
if not OK then
Fail ("creation of auto-init assembly file """,
Macro_File_Name, """ failed");
end if;
end;
-- Invoke the macro-assembler
@ -642,15 +664,6 @@ package body MLib.Tgt is
end if;
end Library_File_Name_For;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
function Linker_Library_Path_Option return String_Access is
begin
return null;
end Linker_Library_Path_Option;
----------------
-- Object_Ext --
----------------

11
gcc/ada/5wml-tgt.adb
View file

@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2003, Ada Core Technologies, Inc. --
-- Copyright (C) 2002-2004, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -308,15 +308,6 @@ package body MLib.Tgt is
end if;
end Library_File_Name_For;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
function Linker_Library_Path_Option return String_Access is
begin
return null;
end Linker_Library_Path_Option;
----------------
-- Object_Ext --
----------------

11
gcc/ada/5zml-tgt.adb
View file

@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2003 Free Software Foundation, Inc. --
-- Copyright (C) 2003-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -278,15 +278,6 @@ package body MLib.Tgt is
end if;
end Library_File_Name_For;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
function Linker_Library_Path_Option return String_Access is
begin
return new String'("-Wl,-R,");
end Linker_Library_Path_Option;
----------------
-- Object_Ext --
----------------

367
gcc/ada/ChangeLog
View file

@ -1,4 +1,367 @@
2004-04-17 Laurent GUERBY <laurent@guerby.net>
2004-04-19 Arnaud Charlet <charlet@act-europe.fr>
* 5isystem.ads: Removed, unused.
* gnat_rm.texi: Redo 1.13 change.
2004-04-19 Robert Dewar <dewar@gnat.com>
* s-stoele.ads: Clean up definition of Storage_Offset (the new
definition is cleaner, avoids the kludge of explicit Standard operator
references, and also is consistent with a visible System.Address with
no visible operations.
* s-geveop.adb: Add declarations to avoid assumption of visible
operations on type System.Address (since these might not be available
if Address is a non-private type for which the operations
are made abstract).
* sem_eval.adb: Minor reformatting
* s-carsi8.ads, s-carun8.ads, s-casi16.ads, s-casi32.ads,
s-casi64.ads, s-caun16.ads, s-caun32.ads, s-caun64.ads: Minor
reformatting (new function spec format).
* s-auxdec.adb, s-carsi8.adb, s-carun8.adb, s-casi16.adb,
s-casi32.adb, s-casi64.adb, s-caun16.adb, s-caun32.adb,
s-caun64.adb: Add declarations to avoid assumption of visible
operations on type System.Address (since these might not be available
if Address is a non-private type for which the operations are made
abstract).
* lib.ads, lib.adb (Synchronize_Serial_Number): New procedure.
* exp_intr.adb: Minor comment update
* exp_aggr.adb, exp_attr.adb, exp_ch13.adb: Minor reformatting.
* 5omastop.adb: Add declarations to avoid assumption of visible
operations on type System.Address (since these might not be available
if Address is a non-private type for which the operations
are made abstract).
2004-04-19 Vincent Celier <celier@gnat.com>
* switch-m.adb: (Scan_Make_Switches): Process new switch -eL
* prj-pars.ads (Parse): New Boolean parameter Process_Languages,
defaulted to Ada.
* prj-proc.adb (Process): New Boolean parameter Process_Languages,
defaulted to Ada.
Call Check with Process_Languages.
(Check): New Boolean parameter Process_Languages. Call Recursive_Check
with Process_Languages.
(Recursive_Check): New Boolean parameter Process_Languages. Call
Nmsc.Ada_Check or Nmsc.Other_Languages_Check according to
Process_Languages.
* prj-proc.ads (Process): New Boolean parameter Process_Languages,
* prj-util.ads, prj-util.adb (Executable_Of): New Boolean
parameter Ada_Main, defaulted to True.
Check for Ada specific characteristics only when Ada_Main is True.
* opt.ads: (Follow_Links): New Boolean flag for gnatmake
* prj.adb: (Project_Empty): Add new Project_Data components.
* prj.ads: New types and tables for non Ada languages.
(Project_Data): New components Languages, Impl_Suffixes,
First_Other_Source, Last_Other_Source, Imported_Directories_Switches,
Include_Path, Include_Data_Set.
* prj-env.ads, prj-env.adb: Minor reformatting
* prj-nmsc.ads, prj-nmsc.adb: (Other_Languages_Check): New procedure
Put subprograms in alphabetical order
* prj-pars.adb (Parse): New Boolean parameter Process_Languages,
defaulted to Ada; Call Prj.Proc.Process with Process_Languages and
Opt.Follow_Links.
* mlib-prj.adb: Back out modification in last version, as they are
incorrect.
(Build_Library.Check_Libs): Remove useless pragma Warnings (Off)
* make.adb: (Mains): Moved to package Makeutl
(Linker_Opts): Moved to package Makeutl
(Is_External_Assignment): Moved to package Makeutl
(Test_If_Relative_Path): Moved to package Makeutl
(Gnatmake): Move sorting of linker options to function
Makeutl.Linker_Options_Switches.
* Makefile.in: Add makeutl.o to the object files for gnatmake
* makeusg.adb: Add line for new switch -eL.
* gnatls.adb (Image): New function.
(Output_Unit): If in verbose mode, output the list of restrictions
specified by pragmas Restrictions.
* 5bml-tgt.adb, 5vml-tgt.adb (Build_Dynamic_Library): Do not use
Text_IO.
* a-calend.adb (Split): Shift the date by multiple of 56 years, if
needed, to put it in the range 1970 (included) - 2026 (excluded).
(Time_Of): Do not shift Unix_Min_Year (1970).
Shift the date by multiple of 56 years, if needed, to put it in the
range 1970 (included) - 2026 (excluded).
* adaint.h, adaint.c (__gnat_set_executable): New function.
2004-04-19 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c (tree_transform, case N_Subprogram_Body): Temporarily push
and pop GC context.
(tree_transform, case N_Procedure_Call): Fix typo in setting TREE_TYPE.
(tree_transform, case N_Label): Don't set LABEL_STMT_FIRST_IN_EH.
(tree_transform, case N_Procedure_Call_Statement): Build a tree.
(tree_transform, case N_Code_Statement): Likewise.
(gnat_expand_stmt, case LABEL_STMT): Don't look at
LABEL_STMT_FIRST_IN_EH.
(gnat_expand_stmt, case ASM_STMT): New case.
* utils2.c (build_unary_op): Properly set TREE_READONLY of
UNCONSTRAINED_ARRAY_REF.
* utils.c (poplevel): Temporarily push/pop GC context around inline
function expansion.
* decl.c (maybe_variable): Properly set TREE_READONLY of
UNCONSTRAINED_ARRAY_REF.
(make_packable_type): Only reference TYPE_IS_PADDING_P for RECORD_TYPE.
* ada-tree.def: (ASM_STMT): New.
* ada-tree.h: (LABEL_STMT_FIRST_IN_EH): Deleted.
(ASM_STMT_TEMPLATE, ASM_STMT_OUTPUT, ASM_STMT_ORIG_OUT,
ASM_STMT_INPUT): New.
(ASM_STMT_CLOBBER): Likewise.
2004-04-19 Thomas Quinot <quinot@act-europe.fr>
* a-except.adb, s-parint.ads, s-parint.adb, types.ads, types.h: Use
general rcheck mechanism to raise Program_Error for E.4(18), instead
of a custom raiser in System.Partition_Interface.
Part of general cleanup work before PolyORB integration.
* snames.ads, snames.adb: Add new runtime library entities and names
for PolyORB DSA.
* sem_dist.ads, sem_dist.adb (Get_Subprogram_Id): Move from sem_dist to
exp_dist.
(Build_Subprogram_Id): New subprogram provided by exp_dist
Code reorganisation in preparation for PolyORB integration.
* exp_dist.ads, exp_dist.adb (Get_Subprogram_Id): Move from sem_dist to
exp_dist.
(Build_Subprogram_Id): New subprogram provided by exp_dist
* sem_ch4.adb (Analyze_One_Call): Fix error message for mismatch in
actual parameter types for call to dereference of an
access-to-subprogram type.
* rtsfind.ads: Add new runtime library entities and names for PolyORB
DSA.
* gnatlink.adb (Value): Remove. Use Interfaces.C.Strings.Value
instead, which has the same behaviour here since we never pass it a
NULL pointer.
* link.c (run_path_option, Solaris case): Use -Wl, as for other
platforms.
* Makefile.in: adjust object file lists for gnatlink and gnatmake
to account for new dependency upon Interfaces.C.Strings + link.o
For x86 FreeBSD, use 86numaux.
* make.adb, gnatcmd.adb: Linker_Library_Path_Option has been moved up
from Mlib.Tgt to Mlib.
* mlib.ads, mlib.adb (Linker_Library_Path_Option): New subprogram, now
target-independent.
* mlib-tgt.ads, mlib-tgt.adb (Linker_Library_Path_Option): Remove
target-specific versions of this subprogram, now implemented as a
target-independent function in Mlib.
* 5aml-tgt.adb, 5bml-tgt.adb, 5gml-tgt.adb, 5hml-tgt.adb, 5lml-tgt.adb,
5sml-tgt.adb, 5vml-tgt.adb, 5zml-tgt.adb, 5wml-tgt.adb
(Linker_Library_Path_Option): Remove target-specific versions of this
subprogram, now implemented as a target-independent function in Mlib.
* atree.adb: (Allocate_Initialize_Node): New subprogram.
Factors out node table slots allocation.
(Fix_Parents): New subprogram.
Encapsulate the pattern of fixing up parent pointers for syntactic
children of a rewritten node.
(New_Copy_Tree): Use New_Copy to copy non-entity nodes.
(Rewrite): Use New_Copy when creating saved copy of original node.
(Replace): Use Copy_Node to copy nodes.
2004-04-19 Javier Miranda <miranda@gnat.com>
* sprint.adb (Sprint_Node_Actual): Give support to the new
Access_To_Subprogram node available in Access_Definition nodes. In
addition, give support to the AI-231 node fields: null-exclusion,
all-present, constant-present.
* sem_util.ads, sem_util.adb: (Has_Declarations): New subprogram
* sinfo.ads, sinfo.adb:
New field Access_To_Subprogram_Definition in Access_Definition nodes
* sem_ch6.adb (Process_Formals): Move here the code that creates and
decorates internal subtype declaration corresponding to the
null-excluding formal. This code was previously in Set_Actual_Subtypes.
In addition, carry out some code cleanup on this code. In case of
access to protected subprogram call
Replace_Anonymous_Access_To_Protected_Subprogram.
(Set_Actual_Subtypes): Code cleanup.
* sem_ch8.adb (Analyze_Object_Renaming): Remove un-necessary call to
Find_Type in case of anonymous access renamings. Add warning in case of
null-excluding attribute used in anonymous access renaming.
* sem_ch3.ads (Replace_Anonymous_Access_To_Protected_Subprogram): New
subprogram
* sem_ch3.adb (Replace_Anonymous_Access_To_Protected_Subprogram): New
subprogram.
(Access_Definition): In case of anonymous access to subprograms call
the corresponding semantic routine to decorate the node.
(Access_Subprogram_Declaration): Addition of some comments indicating
some code that probably should be added here. Detected by comparison
with the access_definition subprogram.
(Analyze_Component_Declaration): In case of access to protected
subprogram call Replace_Anonymous_Access_To_Protected.
(Array_Type_Declaration): In case of access to protected subprogram call
Replace_Anonymous_Access_To_Protected_Subprogram.
(Process_Discriminants): In case of access to protected subprogram call
Replace_Anonymous_Access_To_Protected_Subprogram.
* par.adb (P_Access_Definition): New formal that indicates if the
null-exclusion part was present.
(P_Access_Type_Definition): New formal that indicates if the caller has
already parsed the null-excluding part.
* par-ch3.adb (P_Subtype_Declaration): Code cleanup.
(P_Identifier_Declarations): Code cleanup and give support to renamings
of anonymous access to subprogram types.
(P_Derived_Type_Def_Or_Private_Ext_Decl): Code cleanup.
(P_Array_Type_Definition): Give support to AI-254.
(P_Component_Items): Give support to AI-254.
(P_Access_Definition): New formal that indicates if the header was
already parsed by the caller.
(P_Access_Type_Definition): New formal that indicates if the caller has
already parsed the null-excluding part.
* par-ch6.adb (P_Formal_Part): Add the null-excluding parameter to the
call to P_Access_Definition.
2004-04-19 Geert Bosch <bosch@gnat.com>
* checks.adb (Apply_Float_Conversion_Check): New procedure to implement
the delicate semantics of floating-point to integer conversion.
(Apply_Type_Conversion_Checks): Use Apply_Float_Conversion_Check.
* eval_fat.adb (Machine_Mantissa): Moved to spec.
(Machine_Radix): New function.
* eval_fat.ads (Machine_Mantissa): Moved from body for use in
conversion checks.
(Machine_Radix): New function also for use in conversion checks.
2004-04-19 Ed Schonberg <schonberg@gnat.com>
* par-prag.adb (Source_File_Name_Project): Fix typo in error message.
* exp_ch9.adb (Expand_Access_Protected_Subprogram_Type): Call analyze
to decorate the access-to-protected subprogram and the equivalent type.
* checks.adb (Null_Exclusion_Static_Checks): Code cleanup. Give support
to anonymous access to subprogram types.
* exp_ch4.adb (Expand_N_In): Preserve Static flag before
constant-folding, for legality checks in contexts that require an RM
static expression.
* exp_ch6.adb (Expand_N_Function_Call): If call may generate large
temporary but stack checking is not enabled, increment serial number
to so that symbol generation is consistent with and without stack
checking.
* exp_util.ads, exp_util.adb (May_Generate_Large_Temp): Predicate is
independent on whether stack checking is enabled, caller must check
the corresponding flag.
* sem_ch3.adb (Constrain_Index): Index bounds given by attributes need
range checks.
(Build_Derived_Concurrent_Type): Inherit Is_Constrained flag from
parent if it has discriminants.
(Build_Derived_Private_Type): Constructed full view does
not come from source.
(Process_Discriminants): Default discriminants on a tagged type are
legal if this is the internal completion of a private untagged
derivation.
* sem_ch6.adb (Set_Actual_Subtypes): The generated declaration needs
no constraint checks, because it corresponds to an existing object.
* sem_prag.adb (Process_Convention): Pragma applies
only to subprograms in the same declarative part, i.e. the same unit,
not the same scope.
* sem_res.adb (Valid_Conversion): In an instance or inlined body,
ignore type mismatch on a numeric conversion if expression comes from
expansion.
2004-04-19 Sergey Rybin <rybin@act-europe.fr>
* sem_elim.adb (Process_Eliminate_Pragma): Remove the processing for
Homonym_Number parameter, add processing for Source_Location parameter
corresponding.
(Check_Eliminated): Remove the check for homonym numbers, add the check
for source location traces.
* sem_elim.ads (Process_Eliminate_Pragma): Replace Arg_Homonym_Number
with Arg_Source_Location corresponding to the changes in the format of
the pragma.
* sem_prag.adb: (Analyze_Pragma): Changes in the processing of
Eliminate pragma corresponding to the changes in the format of the
pragma: Homonym_Number is replaced with Source_Location, two ways of
distinguishing homonyms are mutially-exclusive.
2004-04-19 Joel Brobecker <brobecker@gnat.com>
* get_targ.ads (Get_No_Dollar_In_Label): Remove.
* exp_dbug.adb (Output_Homonym_Numbers_Suffix): Remove use of
No_Dollar_In_Label, no longer necessary, as it is always True.
(Strip_Suffixes): Likewise.
2004-04-19 Gary Dismukes <dismukes@gnat.com>
* s-stalib.ads (type Exception_Code): Use Integer'Size for exponent of
modulus for compatibility with size clause on targets with 16-bit
Integer.
* layout.adb (Discrimify): In the case of private types, set Vtyp to
full type to fix type mismatches on calls to size functions for
discriminant-dependent array components.
2004-04-19 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in (gnatlib-zcx): New target, for building a ZCX run-time
lib.
2004-04-19 Pascal Obry <obry@gnat.com>
* mdll-utl.adb (Locate): New version is idempotent.
2004-04-17 Laurent Guerby <laurent@guerby.net>
PR ada/14988 (partial)
* impunit.adb: Fix typo.
@ -692,7 +1055,7 @@
(gnat_to_gnu_entity, case E_Array_Type): Don't set and clear it.
* misc.c (LANG_HOOK_HASH_TYPE): Redefine.
2004-03-19 Laurent GUERBY <laurent@guerby.net>
2004-03-19 Laurent Guerby <laurent@guerby.net>
* sem_prag.adb (Suppress_Unsuppress_Echeck): use loop instead of
aggregate, allows bootstrap from 3.3 on powerpc-darwin.

29
gcc/ada/Makefile.in
View file

@ -300,21 +300,23 @@ Makefile: ../config.status $(srcdir)/Makefile.in $(srcdir)/../version.c
# Lists of files for various purposes.
GNATLINK_OBJS = gnatlink.o link.o \
ali.o alloc.o butil.o casing.o csets.o debug.o fmap.o fname.o gnatvsn.o \
hostparm.o namet.o opt.o osint.o output.o rident.o sdefault.o \
stylesw.o switch.o table.o tree_io.o types.o validsw.o widechar.o
a-except.o ali.o alloc.o butil.o casing.o csets.o debug.o fmap.o fname.o gnatvsn.o \
hostparm.o interfac.o i-c.o i-cstrin.o namet.o opt.o osint.o output.o rident.o \
s-exctab.o s-secsta.o s-stalib.o s-stoele.o sdefault.o stylesw.o switch.o system.o \
table.o tree_io.o types.o validsw.o widechar.o
GNATMAKE_OBJS = ctrl_c.o ali.o ali-util.o s-casuti.o \
GNATMAKE_OBJS = a-except.o ctrl_c.o ali.o ali-util.o s-casuti.o \
alloc.o atree.o binderr.o butil.o casing.o csets.o debug.o elists.o einfo.o\
erroutc.o errutil.o err_vars.o fmap.o fname.o fname-uf.o fname-sf.o \
gnatmake.o gnatvsn.o hostparm.o krunch.o lib.o make.o makeusg.o \
mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o mlib-utl.o \
gnatmake.o gnatvsn.o hostparm.o interfac.o i-c.o i-cstrin.o krunch.o lib.o link.o \
make.o makeusg.o makeutl.o mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o mlib-utl.o \
namet.o nlists.o opt.o osint.o osint-m.o output.o \
prj.o prj-attr.o prj-com.o prj-dect.o prj-env.o prj-err.o prj-ext.o prj-nmsc.o \
prj-pars.o prj-part.o prj-proc.o prj-strt.o prj-tree.o prj-util.o \
rident.o scans.o scng.o sdefault.o sfn_scan.o s-purexc.o s-htable.o \
rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \
scans.o scng.o sdefault.o sfn_scan.o s-purexc.o s-htable.o \
sinfo.o sinput.o sinput-c.o sinput-p.o \
snames.o stand.o stringt.o styleg.o stylesw.o validsw.o switch.o switch-m.o \
snames.o stand.o stringt.o styleg.o stylesw.o system.o validsw.o switch.o switch-m.o \
table.o targparm.o tempdir.o tree_io.o types.o \
uintp.o uname.o urealp.o usage.o widechar.o \
$(EXTRA_GNATMAKE_OBJS)
@ -865,6 +867,8 @@ endif
ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<45intnam.ads \
a-numaux.adb<86numaux.adb \
a-numaux.ads<86numaux.ads \
g-soccon.ads<35soccon.ads \
s-inmaop.adb<7sinmaop.adb \
s-intman.adb<7sintman.adb \
@ -2020,6 +2024,15 @@ gnatlib-sjlj: ../stamp-gnatlib1
THREAD_KIND="$(THREAD_KIND)" \
TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" gnatlib
gnatlib-zcx: ../stamp-gnatlib1
sed -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := True;/' rts/system.ads > rts/s.ads
$(MV) rts/s.ads rts/system.ads
$(MAKE) $(FLAGS_TO_PASS) \
GNATLIBFLAGS="$(GNATLIBFLAGS)" \
GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
THREAD_KIND="$(THREAD_KIND)" \
TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" gnatlib
# .s files for cross-building
gnat-cross: force
make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp"

67
gcc/ada/a-calend.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -89,14 +89,20 @@ package body Ada.Calendar is
-- TM.all cannot be represented.
-- The following constants are used in adjusting Ada dates so that they
-- fit into the range that can be handled by Unix (1970 - 2038). The trick
-- is that the number of days in any four year period in the Ada range of
-- years (1901 - 2099) has a constant number of days. This is because we
-- have the special case of 2000 which, contrary to the normal exception
-- for centuries, is a leap year after all.
-- fit into a 56 year range that can be handled by Unix (1970 included -
-- 2026 excluded). Dates that are not in this 56 year range are shifted
-- by multiples of 56 years to fit in this range
-- The trick is that the number of days in any four year period in the Ada
-- range of years (1901 - 2099) has a constant number of days. This is
-- because we have the special case of 2000 which, contrary to the normal
-- exception for centuries, is a leap year after all.
-- 56 has been chosen, because it is not only a multiple of 4, but also
-- a multiple of 7. Thus two dates 56 years apart fall on the same day of
-- the week, and the Daylight Saving Time change dates are usually the same
-- for these two years.
Unix_Year_Min : constant := 1970;
Unix_Year_Max : constant := 2038;
Unix_Year_Max : constant := 2026;
Ada_Year_Min : constant := 1901;
Ada_Year_Max : constant := 2099;
@ -106,9 +112,10 @@ package body Ada.Calendar is
Days_In_Month : constant array (Month_Number) of Day_Number :=
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
Days_In_4_Years : constant := 365 * 3 + 366;
Seconds_In_4_Years : constant := 86_400 * Days_In_4_Years;
Seconds_In_4_YearsD : constant Duration := Duration (Seconds_In_4_Years);
Days_In_4_Years : constant := 365 * 3 + 366;
Seconds_In_4_Years : constant := 86_400 * Days_In_4_Years;
Seconds_In_56_Years : constant := Seconds_In_4_Years * 14;
Seconds_In_56_YearsD : constant := Duration (Seconds_In_56_Years);
---------
-- "+" --
@ -270,15 +277,6 @@ package body Ada.Calendar is
LowD : constant Duration := Duration (Low);
HighD : constant Duration := Duration (High);
-- The following declare the maximum duration value that can be
-- successfully converted to a 32-bit integer suitable for passing
-- to the localtime_r function. Note that we cannot assume that the
-- localtime_r function expands to accept 64-bit input on a 64-bit
-- machine, but we can count on a 32-bit range on all machines.
Max_Time : constant := 2 ** 31 - 1;
Max_TimeD : constant Duration := Duration (Max_Time);
-- Finally the actual variables used in the computation
D : Duration;
@ -309,21 +307,21 @@ package body Ada.Calendar is
-- EPOCH through EPOCH + N seconds). N is in practice 2 ** 31 - 1.
-- If we have a value outside this range, then we first adjust it
-- to be in the required range by adding multiples of four years.
-- to be in the required range by adding multiples of 56 years.
-- For the range we are interested in, the number of days in any
-- consecutive four year period is constant. Then we do the split
-- consecutive 56 year period is constant. Then we do the split
-- on the adjusted value, and readjust the years value accordingly.
Year_Val := 0;
while D < 0.0 loop
D := D + Seconds_In_4_YearsD;
Year_Val := Year_Val - 4;
D := D + Seconds_In_56_YearsD;
Year_Val := Year_Val - 56;
end loop;
while D > Max_TimeD loop
D := D - Seconds_In_4_YearsD;
Year_Val := Year_Val + 4;
while D >= Seconds_In_56_YearsD loop
D := D - Seconds_In_56_YearsD;
Year_Val := Year_Val + 56;
end loop;
-- Now we need to take the value D, which is now non-negative, and
@ -435,18 +433,19 @@ package body Ada.Calendar is
TM_Val.tm_mon := Month - 1;
-- For the year, we have to adjust it to a year that Unix can handle.
-- We do this in four year steps, since the number of days in four
-- years is constant, so the timezone effect on the conversion from
-- local time to GMT is unaffected.
-- We do this in 56 year steps, since the number of days in 56 years
-- is constant, so the timezone effect on the conversion from local
-- time to GMT is unaffected; also the DST change dates are usually
-- not modified.
while Year_Val <= Unix_Year_Min loop
Year_Val := Year_Val + 4;
Duration_Adjust := Duration_Adjust - Seconds_In_4_YearsD;
while Year_Val < Unix_Year_Min loop
Year_Val := Year_Val + 56;
Duration_Adjust := Duration_Adjust - Seconds_In_56_YearsD;
end loop;
while Year_Val >= Unix_Year_Max loop
Year_Val := Year_Val - 4;
Duration_Adjust := Duration_Adjust + Seconds_In_4_YearsD;
Year_Val := Year_Val - 56;
Duration_Adjust := Duration_Adjust + Seconds_In_56_YearsD;
end loop;
TM_Val.tm_year := Year_Val - 1900;

21
gcc/ada/a-except.adb
View file

@ -501,6 +501,7 @@ package body Ada.Exceptions is
procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_29 (File : Big_String_Ptr; Line : Integer);
pragma Export (C, Rcheck_00, "__gnat_rcheck_00");
pragma Export (C, Rcheck_01, "__gnat_rcheck_01");
@ -531,6 +532,7 @@ package body Ada.Exceptions is
pragma Export (C, Rcheck_26, "__gnat_rcheck_26");
pragma Export (C, Rcheck_27, "__gnat_rcheck_27");
pragma Export (C, Rcheck_28, "__gnat_rcheck_28");
pragma Export (C, Rcheck_29, "__gnat_rcheck_29");
---------------------------------------------
-- Reason Strings for Run-Time Check Calls --
@ -565,11 +567,13 @@ package body Ada.Exceptions is
Rmsg_21 : constant String := "potentially blocking operation" & NUL;
Rmsg_22 : constant String := "stubbed subprogram called" & NUL;
Rmsg_23 : constant String := "unchecked union restriction" & NUL;
Rmsg_24 : constant String := "empty storage pool" & NUL;
Rmsg_25 : constant String := "explicit raise" & NUL;
Rmsg_26 : constant String := "infinite recursion" & NUL;
Rmsg_27 : constant String := "object too large" & NUL;
Rmsg_28 : constant String := "restriction violation" & NUL;
Rmsg_24 : constant String := "illegal use of"
& " remote access-to-class-wide type, see RM E.4(18)" & NUL;
Rmsg_25 : constant String := "empty storage pool" & NUL;
Rmsg_26 : constant String := "explicit raise" & NUL;
Rmsg_27 : constant String := "infinite recursion" & NUL;
Rmsg_28 : constant String := "object too large" & NUL;
Rmsg_29 : constant String := "restriction violation" & NUL;
-----------------------
-- Polling Interface --
@ -1146,7 +1150,7 @@ package body Ada.Exceptions is
procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_24'Address));
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_24'Address));
end Rcheck_24;
procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is
@ -1169,6 +1173,11 @@ package body Ada.Exceptions is
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_28'Address));
end Rcheck_28;
procedure Rcheck_29 (File : Big_String_Ptr; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_29'Address));
end Rcheck_29;
-------------
-- Reraise --
-------------

7
gcc/ada/ada-tree.def
View file

@ -101,9 +101,12 @@ DEFTREECODE (IF_STMT, "if_stmt", 's', 4)
/* A goto just points to the label: GOTO_STMT_LABEL. */
DEFTREECODE (GOTO_STMT, "goto_stmt", 's', 1)
/* A label: LABEL_STMT_LABEL is the label and LABEL_STMT_FIRST_IN_EH is set
if this is the first label of an exception handler. */
/* A label: LABEL_STMT_LABEL is the label. */
DEFTREECODE (LABEL_STMT, "label_stmt", 's', 1)
/* A "return". RETURN_STMT_EXPR is the value to return if non-null. */
DEFTREECODE (RETURN_STMT, "return_stmt", 's', 1)
/* An "asm" statement. The operands are ASM_STMT_TEMPLATE, ASM_STMT_OUTPUT,
ASM_STMT_ORIG_OUT, ASM_STMT_INPUT, and ASM_STMT_CLOBBER. */
DEFTREECODE (ASM_STMT, "asm_stmt", 's', 5)

8
gcc/ada/ada-tree.h
View file

@ -302,7 +302,9 @@ struct lang_type GTY(())
#define IF_STMT_ELSE(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 3)
#define GOTO_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, GOTO_STMT, 0)
#define LABEL_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, LABEL_STMT, 0)
#define LABEL_STMT_FIRST_IN_EH(NODE) \
(LABEL_STMT_CHECK (NODE)->common.unsigned_flag)
#define RETURN_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, RETURN_STMT, 0)
#define ASM_STMT_TEMPLATE(NODE) TREE_OPERAND_CHECK_CODE (NODE, ASM_STMT, 0)
#define ASM_STMT_OUTPUT(NODE) TREE_OPERAND_CHECK_CODE (NODE, ASM_STMT, 1)
#define ASM_STMT_ORIG_OUT(NODE) TREE_OPERAND_CHECK_CODE (NODE, ASM_STMT, 2)
#define ASM_STMT_INPUT(NODE) TREE_OPERAND_CHECK_CODE (NODE, ASM_STMT, 3)
#define ASM_STMT_CLOBBER(NODE) TREE_OPERAND_CHECK_CODE (NODE, ASM_STMT, 4)

14
gcc/ada/adaint.c
View file

@ -1471,6 +1471,20 @@ __gnat_set_writable (char *name)
#endif
}
void
__gnat_set_executable (char *name)
{
#ifndef __vxworks
struct stat statbuf;
if (stat (name, &statbuf) == 0)
{
statbuf.st_mode = statbuf.st_mode | S_IXUSR;
chmod (name, statbuf.st_mode);
}
#endif
}
void
__gnat_set_readonly (char *name)
{

1
gcc/ada/adaint.h
View file

@ -83,6 +83,7 @@ extern int __gnat_is_writable_file (char *);
extern int __gnat_is_readable_file (char *name);
extern void __gnat_set_readonly (char *name);
extern void __gnat_set_writable (char *name);
extern void __gnat_set_executable (char *name);
extern int __gnat_is_symbolic_link (char *name);
extern int __gnat_portable_spawn (char *[]);
extern int __gnat_portable_no_block_spawn (char *[]);

294
gcc/ada/atree.adb
View file

@ -380,11 +380,64 @@ package body Atree is
-- Local Subprograms --
-----------------------
procedure Fix_Parent (Field : Union_Id; Old_Node, New_Node : Node_Id);
-- This subprogram is used to fixup parent pointers that are rendered
-- incorrect because of a node copy. Field is checked to see if it
-- points to a node, list, or element list that has a parent that
-- points to Old_Node. If so, the parent is reset to point to New_Node.
procedure Fix_Parents (Old_Node, New_Node : Node_Id);
-- Fixup parent pointers for the syntactic children of New_Node after
-- a copy, setting them to New_Node when they pointed to Old_Node.
function Allocate_Initialize_Node
(Src : Node_Id;
With_Extension : Boolean) return Node_Id;
-- Allocate a new node or node extension. If Src is not empty,
-- the information for the newly-allocated node is copied from it.
------------------------------
-- Allocate_Initialize_Node --
------------------------------
function Allocate_Initialize_Node
(Src : Node_Id;
With_Extension : Boolean) return Node_Id
is
New_Id : Node_Id := Src;
Nod : Node_Record := Default_Node;
Ext1 : Node_Record := Default_Node_Extension;
Ext2 : Node_Record := Default_Node_Extension;
Ext3 : Node_Record := Default_Node_Extension;
begin
if Present (Src) then
Nod := Nodes.Table (Src);
if Has_Extension (Src) then
Ext1 := Nodes.Table (Src + 1);
Ext2 := Nodes.Table (Src + 2);
Ext3 := Nodes.Table (Src + 3);
end if;
end if;
if not (Present (Src)
and then not Has_Extension (Src)
and then With_Extension
and then Src = Nodes.Last)
then
-- We are allocating a new node, or extending a node
-- other than Nodes.Last.
Nodes.Append (Nod);
New_Id := Nodes.Last;
Orig_Nodes.Append (New_Id);
Node_Count := Node_Count + 1;
end if;
if With_Extension then
Nodes.Append (Ext1);
Nodes.Append (Ext2);
Nodes.Append (Ext3);
end if;
Orig_Nodes.Set_Last (Nodes.Last);
Allocate_List_Tables (Nodes.Last);
return New_Id;
end Allocate_Initialize_Node;
--------------
-- Analyzed --
@ -584,17 +637,7 @@ package body Atree is
return Copy_Entity (Source);
else
Nodes.Increment_Last;
New_Id := Nodes.Last;
Nodes.Table (New_Id) := Nodes.Table (Source);
Nodes.Table (New_Id).Link := Empty_List_Or_Node;
Nodes.Table (New_Id).In_List := False;
Nodes.Table (New_Id).Rewrite_Ins := False;
Node_Count := Node_Count + 1;
Orig_Nodes.Increment_Last;
Allocate_List_Tables (Nodes.Last);
Orig_Nodes.Table (New_Id) := New_Id;
New_Id := New_Copy (Source);
-- Recursively copy descendents
@ -787,58 +830,53 @@ package body Atree is
pragma Inline (Debug_Extend_Node);
begin
if Node /= Nodes.Last then
Nodes.Increment_Last;
Nodes.Table (Nodes.Last) := Nodes.Table (Node);
Result := Nodes.Last;
Orig_Nodes.Increment_Last;
Orig_Nodes.Table (Nodes.Last) := Nodes.Last;
else
Result := Node;
end if;
Nodes.Increment_Last;
Nodes.Table (Nodes.Last) := Default_Node_Extension;
Nodes.Increment_Last;
Nodes.Table (Nodes.Last) := Default_Node_Extension;
Nodes.Increment_Last;
Nodes.Table (Nodes.Last) := Default_Node_Extension;
Orig_Nodes.Set_Last (Nodes.Last);
Allocate_List_Tables (Nodes.Last);
pragma Assert (not (Has_Extension (Node)));
Result := Allocate_Initialize_Node (Node, With_Extension => True);
pragma Debug (Debug_Extend_Node);
return Result;
end Extend_Node;
----------------
-- Fix_Parent --
----------------
-----------------
-- Fix_Parents --
-----------------
procedure Fix_Parents (Old_Node, New_Node : Node_Id) is
procedure Fix_Parent (Field : Union_Id; Old_Node, New_Node : Node_Id);
-- Fixup one parent pointer. Field is checked to see if it
-- points to a node, list, or element list that has a parent that
-- points to Old_Node. If so, the parent is reset to point to New_Node.
procedure Fix_Parent (Field : Union_Id; Old_Node, New_Node : Node_Id) is
begin
-- Fix parent of node that is referenced by Field. Note that we must
-- exclude the case where the node is a member of a list, because in
-- this case the parent is the parent of the list.
if Field in Node_Range
and then Present (Node_Id (Field))
and then not Nodes.Table (Node_Id (Field)).In_List
and then Parent (Node_Id (Field)) = Old_Node
then
Set_Parent (Node_Id (Field), New_Node);
-- Fix parent of list that is referenced by Field
elsif Field in List_Range
and then Present (List_Id (Field))
and then Parent (List_Id (Field)) = Old_Node
then
Set_Parent (List_Id (Field), New_Node);
end if;
end Fix_Parent;
procedure Fix_Parent (Field : Union_Id; Old_Node, New_Node : Node_Id) is
begin
-- Fix parent of node that is referenced by Field. Note that we must
-- exclude the case where the node is a member of a list, because in
-- this case the parent is the parent of the list.
if Field in Node_Range
and then Present (Node_Id (Field))
and then not Nodes.Table (Node_Id (Field)).In_List
and then Parent (Node_Id (Field)) = Old_Node
then
Set_Parent (Node_Id (Field), New_Node);
-- Fix parent of list that is referenced by Field
elsif Field in List_Range
and then Present (List_Id (Field))
and then Parent (List_Id (Field)) = Old_Node
then
Set_Parent (List_Id (Field), New_Node);
end if;
end Fix_Parent;
Fix_Parent (Field1 (New_Node), Old_Node, New_Node);
Fix_Parent (Field2 (New_Node), Old_Node, New_Node);
Fix_Parent (Field3 (New_Node), Old_Node, New_Node);
Fix_Parent (Field4 (New_Node), Old_Node, New_Node);
Fix_Parent (Field5 (New_Node), Old_Node, New_Node);
end Fix_Parents;
-----------------------------------
-- Get_Comes_From_Source_Default --
@ -942,38 +980,23 @@ package body Atree is
--------------
function New_Copy (Source : Node_Id) return Node_Id is
New_Id : Node_Id;
New_Id : Node_Id := Source;
begin
if Source <= Empty_Or_Error then
return Source;
if Source > Empty_Or_Error then
New_Id := Allocate_Initialize_Node (Source, Has_Extension (Source));
else
Nodes.Increment_Last;
New_Id := Nodes.Last;
Nodes.Table (New_Id) := Nodes.Table (Source);
Nodes.Table (New_Id).Link := Empty_List_Or_Node;
Nodes.Table (New_Id).In_List := False;
-- If the original is marked as a rewrite insertion, then unmark
-- the copy, since we inserted the original, not the copy.
Nodes.Table (New_Id).Rewrite_Ins := False;
Orig_Nodes.Increment_Last;
Orig_Nodes.Table (New_Id) := New_Id;
if Has_Extension (Source) then
Nodes.Increment_Last;
Nodes.Table (New_Id + 1) := Nodes.Table (Source + 1);
Nodes.Increment_Last;
Nodes.Table (New_Id + 2) := Nodes.Table (Source + 2);
Nodes.Increment_Last;
Nodes.Table (New_Id + 3) := Nodes.Table (Source + 3);
Orig_Nodes.Set_Last (Nodes.Last);
end if;
Allocate_List_Tables (Nodes.Last);
Node_Count := Node_Count + 1;
return New_Id;
end if;
return New_Id;
end New_Copy;
-------------------
@ -1353,17 +1376,7 @@ package body Atree is
return Assoc (Old_Node);
else
Nodes.Increment_Last;
New_Node := Nodes.Last;
Nodes.Table (New_Node) := Nodes.Table (Old_Node);
Nodes.Table (New_Node).Link := Empty_List_Or_Node;
Nodes.Table (New_Node).In_List := False;
Node_Count := Node_Count + 1;
Orig_Nodes.Increment_Last;
Allocate_List_Tables (Nodes.Last);
Orig_Nodes.Table (Nodes.Last) := Nodes.Last;
New_Node := New_Copy (Old_Node);
-- If the node we are copying is the associated node of a
-- previously copied Itype, then adjust the associated node
@ -1416,10 +1429,6 @@ package body Atree is
Set_Field5
(New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
-- If the original is marked as a rewrite insertion, then unmark
-- the copy, since we inserted the original, not the copy.
Nodes.Table (New_Node).Rewrite_Ins := False;
-- Adjust Sloc of new node if necessary
@ -1838,7 +1847,7 @@ package body Atree is
begin
if Debug_Flag_N then
Write_Str ("Allocate entity, Id = ");
Write_Int (Int (Nodes.Last));
Write_Int (Int (Ent));
Write_Str (" ");
Write_Location (New_Sloc);
Write_Str (" ");
@ -1852,8 +1861,7 @@ package body Atree is
begin
pragma Assert (New_Node_Kind in N_Entity);
Nodes.Increment_Last;
Ent := Nodes.Last;
Ent := Allocate_Initialize_Node (Empty, With_Extension => True);
-- If this is a node with a real location and we are generating
-- source nodes, then reset Current_Error_Node. This is useful
@ -1863,26 +1871,10 @@ package body Atree is
Current_Error_Node := Ent;
end if;
Nodes.Table (Nodes.Last) := Default_Node;
Nodes.Table (Nodes.Last).Nkind := New_Node_Kind;
Nodes.Table (Nodes.Last).Sloc := New_Sloc;
Nodes.Table (Ent).Nkind := New_Node_Kind;
Nodes.Table (Ent).Sloc := New_Sloc;
pragma Debug (New_Entity_Debugging_Output);
Orig_Nodes.Increment_Last;
Orig_Nodes.Table (Nodes.Last) := Nodes.Last;
Nodes.Increment_Last;
Nodes.Table (Nodes.Last) := Default_Node_Extension;
Nodes.Increment_Last;
Nodes.Table (Nodes.Last) := Default_Node_Extension;
Nodes.Increment_Last;
Nodes.Table (Nodes.Last) := Default_Node_Extension;
Orig_Nodes.Set_Last (Nodes.Last);
Allocate_List_Tables (Nodes.Last);
Node_Count := Node_Count + 1;
return Ent;
end New_Entity;
@ -1908,7 +1900,7 @@ package body Atree is
begin
if Debug_Flag_N then
Write_Str ("Allocate node, Id = ");
Write_Int (Int (Nodes.Last));
Write_Int (Int (Nod));
Write_Str (" ");
Write_Location (New_Sloc);
Write_Str (" ");
@ -1921,12 +1913,10 @@ package body Atree is
begin
pragma Assert (New_Node_Kind not in N_Entity);
Nodes.Increment_Last;
Nodes.Table (Nodes.Last) := Default_Node;
Nodes.Table (Nodes.Last).Nkind := New_Node_Kind;
Nodes.Table (Nodes.Last).Sloc := New_Sloc;
Nod := Allocate_Initialize_Node (Empty, With_Extension => False);
Nodes.Table (Nod).Nkind := New_Node_Kind;
Nodes.Table (Nod).Sloc := New_Sloc;
pragma Debug (New_Node_Debugging_Output);
Nod := Nodes.Last;
-- If this is a node with a real location and we are generating
-- source nodes, then reset Current_Error_Node. This is useful
@ -1936,10 +1926,6 @@ package body Atree is
Current_Error_Node := Nod;
end if;
Node_Count := Node_Count + 1;
Orig_Nodes.Increment_Last;
Allocate_List_Tables (Nodes.Last);
Orig_Nodes.Table (Nodes.Last) := Nodes.Last;
return Nod;
end New_Node;
@ -2054,11 +2040,7 @@ package body Atree is
end if;
New_Node := New_Copy (Source);
Fix_Parent (Field1 (Source), Source, New_Node);
Fix_Parent (Field2 (Source), Source, New_Node);
Fix_Parent (Field3 (Source), Source, New_Node);
Fix_Parent (Field4 (Source), Source, New_Node);
Fix_Parent (Field5 (Source), Source, New_Node);
Fix_Parents (Source, New_Node);
-- We now set the parent of the new node to be the same as the
-- parent of the source. Almost always this parent will be
@ -2085,8 +2067,6 @@ package body Atree is
-------------
procedure Replace (Old_Node, New_Node : Node_Id) is
Old_Link : constant Union_Id := Nodes.Table (Old_Node).Link;
Old_InL : constant Boolean := Nodes.Table (Old_Node).In_List;
Old_Post : constant Boolean := Nodes.Table (Old_Node).Error_Posted;
Old_CFS : constant Boolean := Nodes.Table (Old_Node).Comes_From_Source;
@ -2098,19 +2078,13 @@ package body Atree is
-- Do copy, preserving link and in list status and comes from source
Nodes.Table (Old_Node) := Nodes.Table (New_Node);
Nodes.Table (Old_Node).Link := Old_Link;
Nodes.Table (Old_Node).In_List := Old_InL;
Copy_Node (Source => New_Node, Destination => Old_Node);
Nodes.Table (Old_Node).Comes_From_Source := Old_CFS;
Nodes.Table (Old_Node).Error_Posted := Old_Post;
-- Fix parents of substituted node, since it has changed identity
Fix_Parent (Field1 (Old_Node), New_Node, Old_Node);
Fix_Parent (Field2 (Old_Node), New_Node, Old_Node);
Fix_Parent (Field3 (Old_Node), New_Node, Old_Node);
Fix_Parent (Field4 (Old_Node), New_Node, Old_Node);
Fix_Parent (Field5 (Old_Node), New_Node, Old_Node);
Fix_Parents (New_Node, Old_Node);
-- Since we are doing a replace, we assume that the original node
-- is intended to become the new replaced node. The call would be
@ -2129,10 +2103,8 @@ package body Atree is
procedure Rewrite (Old_Node, New_Node : Node_Id) is
Old_Link : constant Union_Id := Nodes.Table (Old_Node).Link;
Old_In_List : constant Boolean := Nodes.Table (Old_Node).In_List;
Old_Error_P : constant Boolean := Nodes.Table (Old_Node).Error_Posted;
-- These three fields are always preserved in the new node
-- This fields is always preserved in the new node
Old_Paren_Count : Paren_Count_Type;
Old_Must_Not_Freeze : Boolean;
@ -2165,24 +2137,14 @@ package body Atree is
-- that does not reference the Old_Node.
if Orig_Nodes.Table (Old_Node) = Old_Node then
Nodes.Increment_Last;
Sav_Node := Nodes.Last;
Nodes.Table (Sav_Node) := Nodes.Table (Old_Node);
Nodes.Table (Sav_Node).In_List := False;
Nodes.Table (Sav_Node).Link := Union_Id (Parent (Old_Node));
Orig_Nodes.Increment_Last;
Allocate_List_Tables (Nodes.Last);
Sav_Node := New_Copy (Old_Node);
Orig_Nodes.Table (Sav_Node) := Sav_Node;
Orig_Nodes.Table (Old_Node) := Sav_Node;
end if;
-- Copy substitute node into place, preserving old fields as required
Nodes.Table (Old_Node) := Nodes.Table (New_Node);
Nodes.Table (Old_Node).Link := Old_Link;
Nodes.Table (Old_Node).In_List := Old_In_List;
Copy_Node (Source => New_Node, Destination => Old_Node);
Nodes.Table (Old_Node).Error_Posted := Old_Error_P;
if Nkind (New_Node) in N_Subexpr then
@ -2190,11 +2152,7 @@ package body Atree is
Set_Must_Not_Freeze (Old_Node, Old_Must_Not_Freeze);
end if;
Fix_Parent (Field1 (Old_Node), New_Node, Old_Node);
Fix_Parent (Field2 (Old_Node), New_Node, Old_Node);
Fix_Parent (Field3 (Old_Node), New_Node, Old_Node);
Fix_Parent (Field4 (Old_Node), New_Node, Old_Node);
Fix_Parent (Field5 (Old_Node), New_Node, Old_Node);
Fix_Parents (New_Node, Old_Node);
end Rewrite;
------------------

474
gcc/ada/checks.adb
View file

@ -31,6 +31,7 @@ with Errout; use Errout;
with Exp_Ch2; use Exp_Ch2;
with Exp_Util; use Exp_Util;
with Elists; use Elists;
with Eval_Fat; use Eval_Fat;
with Freeze; use Freeze;
with Lib; use Lib;
with Nlists; use Nlists;
@ -187,6 +188,14 @@ package body Checks is
-- Local Subprograms --
-----------------------
procedure Apply_Float_Conversion_Check
(Ck_Node : Node_Id;
Target_Typ : Entity_Id);
-- The checks on a conversion from a floating-point type to an integer
-- type are delicate. They have to be performed before conversion, they
-- have to raise an exception when the operand is a NaN, and rounding must
-- be taken into account to determine the safe bounds of the operand.
procedure Apply_Selected_Length_Checks
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
@ -1346,6 +1355,186 @@ package body Checks is
end if;
end Apply_Divide_Check;
----------------------------------
-- Apply_Float_Conversion_Check --
----------------------------------
-- Let F and I be the source and target types of the conversion.
-- The Ada standard specifies that a floating-point value X is rounded
-- to the nearest integer, with halfway cases being rounded away from
-- zero. The rounded value of X is checked against I'Range.
-- The catch in the above paragraph is that there is no good way
-- to know whether the round-to-integer operation resulted in
-- overflow. A remedy is to perform a range check in the floating-point
-- domain instead, however:
-- (1) The bounds may not be known at compile time
-- (2) The check must take into account possible rounding.
-- (3) The range of type I may not be exactly representable in F.
-- (4) The end-points I'First - 0.5 and I'Last + 0.5 may or may
-- not be in range, depending on the sign of I'First and I'Last.
-- (5) X may be a NaN, which will fail any comparison
-- The following steps take care of these issues converting X:
-- (1) If either I'First or I'Last is not known at compile time, use
-- I'Base instead of I in the next three steps and perform a
-- regular range check against I'Range after conversion.
-- (2) If I'First - 0.5 is representable in F then let Lo be that
-- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
-- F'Machine (T) and let Lo_OK be (Lo >= I'First). In other words,
-- take one of the closest floating-point numbers to T, and see if
-- it is in range or not.
-- (3) If I'Last + 0.5 is representable in F then let Hi be that value
-- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
-- F'Rounding (T) and let Hi_OK be (Hi <= I'Last).
-- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
-- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
procedure Apply_Float_Conversion_Check
(Ck_Node : Node_Id;
Target_Typ : Entity_Id)
is
LB : constant Node_Id := Type_Low_Bound (Target_Typ);
HB : constant Node_Id := Type_High_Bound (Target_Typ);
Loc : constant Source_Ptr := Sloc (Ck_Node);
Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node));
Target_Base : constant Entity_Id := Implementation_Base_Type
(Target_Typ);
Max_Bound : constant Uint := UI_Expon
(Machine_Radix (Expr_Type),
Machine_Mantissa (Expr_Type) - 1) - 1;
-- Largest bound, so bound plus or minus half is a machine number of F
Ifirst,
Ilast : Uint; -- Bounds of integer type
Lo, Hi : Ureal; -- Bounds to check in floating-point domain
Lo_OK,
Hi_OK : Boolean; -- True iff Lo resp. Hi belongs to I'Range
Lo_Chk,
Hi_Chk : Node_Id; -- Expressions that are False iff check fails
Reason : RT_Exception_Code;
begin
if not Compile_Time_Known_Value (LB)
or not Compile_Time_Known_Value (HB)
then
declare
-- First check that the value falls in the range of the base
-- type, to prevent overflow during conversion and then
-- perform a regular range check against the (dynamic) bounds.
Par : constant Node_Id := Parent (Ck_Node);
pragma Assert (Target_Base /= Target_Typ);
pragma Assert (Nkind (Par) = N_Type_Conversion);
Temp : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('T'));
begin
Apply_Float_Conversion_Check (Ck_Node, Target_Base);
Set_Etype (Temp, Target_Base);
Insert_Action (Parent (Par),
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Occurrence_Of (Target_Typ, Loc),
Expression => New_Copy_Tree (Par)),
Suppress => All_Checks);
Insert_Action (Par,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Not_In (Loc,
Left_Opnd => New_Occurrence_Of (Temp, Loc),
Right_Opnd => New_Occurrence_Of (Target_Typ, Loc)),
Reason => CE_Range_Check_Failed));
Rewrite (Par, New_Occurrence_Of (Temp, Loc));
return;
end;
end if;
-- Get the bounds of the target type
Ifirst := Expr_Value (LB);
Ilast := Expr_Value (HB);
-- Check against lower bound
if abs (Ifirst) < Max_Bound then
Lo := UR_From_Uint (Ifirst) - Ureal_Half;
Lo_OK := (Ifirst > 0);
else
Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node);
Lo_OK := (Lo >= UR_From_Uint (Ifirst));
end if;
if Lo_OK then
-- Lo_Chk := (X >= Lo)
Lo_Chk := Make_Op_Ge (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
Right_Opnd => Make_Real_Literal (Loc, Lo));
else
-- Lo_Chk := (X > Lo)
Lo_Chk := Make_Op_Gt (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
Right_Opnd => Make_Real_Literal (Loc, Lo));
end if;
-- Check against higher bound
if abs (Ilast) < Max_Bound then
Hi := UR_From_Uint (Ilast) + Ureal_Half;
Hi_OK := (Ilast < 0);
else
Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Ck_Node);
Hi_OK := (Hi <= UR_From_Uint (Ilast));
end if;
if Hi_OK then
-- Hi_Chk := (X <= Hi)
Hi_Chk := Make_Op_Le (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
Right_Opnd => Make_Real_Literal (Loc, Hi));
else
-- Hi_Chk := (X < Hi)
Hi_Chk := Make_Op_Lt (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
Right_Opnd => Make_Real_Literal (Loc, Hi));
end if;
-- If the bounds of the target type are the same as those of the
-- base type, the check is an overflow check as a range check is
-- not performed in these cases.
if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst
and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast
then
Reason := CE_Overflow_Check_Failed;
else
Reason := CE_Range_Check_Failed;
end if;
-- Raise CE if either conditions does not hold
Insert_Action (Ck_Node,
Make_Raise_Constraint_Error (Loc,
Condition => Make_Op_Not (Loc, Make_Op_And (Loc, Lo_Chk, Hi_Chk)),
Reason => Reason));
end Apply_Float_Conversion_Check;
------------------------
-- Apply_Length_Check --
------------------------
@ -1918,9 +2107,14 @@ package body Checks is
-- and no floating point type is involved in the type conversion
-- then fixed point values must be read as integral values.
Float_To_Int : constant Boolean :=
Is_Floating_Point_Type (Expr_Type)
and then Is_Integer_Type (Target_Type);
begin
if not Overflow_Checks_Suppressed (Target_Base)
and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
and then not Float_To_Int
then
Set_Do_Overflow_Check (N);
end if;
@ -1928,8 +2122,12 @@ package body Checks is
if not Range_Checks_Suppressed (Target_Type)
and then not Range_Checks_Suppressed (Expr_Type)
then
Apply_Scalar_Range_Check
(Expr, Target_Type, Fixed_Int => Conv_OK);
if Float_To_Int then
Apply_Float_Conversion_Check (Expr, Target_Type);
else
Apply_Scalar_Range_Check
(Expr, Target_Type, Fixed_Int => Conv_OK);
end if;
end if;
end;
@ -2193,162 +2391,214 @@ package body Checks is
procedure Null_Exclusion_Static_Checks (N : Node_Id) is
K : constant Node_Kind := Nkind (N);
Expr : Node_Id;
Typ : Entity_Id;
Related_Nod : Node_Id;
Has_Null_Exclusion : Boolean := False;
-- Following declarations and subprograms are just used to qualify the
-- error messages
type Msg_Kind is (Components, Formals, Objects);
Msg_K : Msg_Kind := Objects;
-- Used by local subprograms to generate precise error messages
procedure Must_Be_Initialized;
procedure Null_Not_Allowed;
procedure Check_Must_Be_Access
(Typ : Entity_Id;
Has_Null_Exclusion : Boolean);
-- ??? local subprograms must have comment on spec
-------------------------
-- Must_Be_Initialized --
-------------------------
procedure Check_Already_Null_Excluding_Type
(Typ : Entity_Id;
Has_Null_Exclusion : Boolean;
Related_Nod : Node_Id);
-- ??? local subprograms must have comment on spec
procedure Must_Be_Initialized is
procedure Check_Must_Be_Initialized
(N : Node_Id;
Related_Nod : Node_Id);
-- ??? local subprograms must have comment on spec
procedure Check_Null_Not_Allowed (N : Node_Id);
-- ??? local subprograms must have comment on spec
-- ??? following bodies lack comments
--------------------------
-- Check_Must_Be_Access --
--------------------------
procedure Check_Must_Be_Access
(Typ : Entity_Id;
Has_Null_Exclusion : Boolean)
is
begin
case Msg_K is
when Components =>
Error_Msg_N
("(Ada 0Y) null-excluding components must be initialized",
Related_Nod);
if Has_Null_Exclusion
and then not Is_Access_Type (Typ)
then
Error_Msg_N ("(Ada 0Y) must be an access type", Related_Nod);
end if;
end Check_Must_Be_Access;
when Formals =>
Error_Msg_N
("(Ada 0Y) null-excluding formals must be initialized",
Related_Nod);
---------------------------------------
-- Check_Already_Null_Excluding_Type --
---------------------------------------
when Objects =>
Error_Msg_N
("(Ada 0Y) null-excluding objects must be initialized",
Related_Nod);
end case;
end Must_Be_Initialized;
----------------------
-- Null_Not_Allowed --
----------------------
procedure Null_Not_Allowed is
procedure Check_Already_Null_Excluding_Type
(Typ : Entity_Id;
Has_Null_Exclusion : Boolean;
Related_Nod : Node_Id)
is
begin
case Msg_K is
when Components =>
Error_Msg_N
("(Ada 0Y) NULL not allowed in null-excluding components",
Expr);
if Has_Null_Exclusion
and then Can_Never_Be_Null (Typ)
then
Error_Msg_N
("(Ada 0Y) already a null-excluding type", Related_Nod);
end if;
end Check_Already_Null_Excluding_Type;
when Formals =>
Error_Msg_N
("(Ada 0Y) NULL not allowed in null-excluding formals",
Expr);
-------------------------------
-- Check_Must_Be_Initialized --
-------------------------------
when Objects =>
Error_Msg_N
("(Ada 0Y) NULL not allowed in null-excluding objects",
Expr);
end case;
end Null_Not_Allowed;
procedure Check_Must_Be_Initialized
(N : Node_Id;
Related_Nod : Node_Id)
is
Expr : constant Node_Id := Expression (N);
begin
pragma Assert (Nkind (N) = N_Component_Declaration
or else Nkind (N) = N_Object_Declaration);
if not Present (Expr) then
case Msg_K is
when Components =>
Error_Msg_N
("(Ada 0Y) null-excluding components must be initialized",
Related_Nod);
when Formals =>
Error_Msg_N
("(Ada 0Y) null-excluding formals must be initialized",
Related_Nod);
when Objects =>
Error_Msg_N
("(Ada 0Y) null-excluding objects must be initialized",
Related_Nod);
end case;
end if;
end Check_Must_Be_Initialized;
----------------------------
-- Check_Null_Not_Allowed --
----------------------------
procedure Check_Null_Not_Allowed (N : Node_Id) is
Expr : constant Node_Id := Expression (N);
begin
if Present (Expr)
and then Nkind (Expr) = N_Null
then
case Msg_K is
when Components =>
Error_Msg_N
("(Ada 0Y) NULL not allowed in null-excluding components",
Expr);
when Formals =>
Error_Msg_N
("(Ada 0Y) NULL not allowed in null-excluding formals",
Expr);
when Objects =>
Error_Msg_N
("(Ada 0Y) NULL not allowed in null-excluding objects",
Expr);
end case;
end if;
end Check_Null_Not_Allowed;
-- Start of processing for Null_Exclusion_Static_Checks
begin
pragma Assert (K = N_Component_Declaration
or else K = N_Parameter_Specification
or else K = N_Object_Declaration
or else K = N_Discriminant_Specification
or else K = N_Allocator);
Expr := Expression (N);
or else K = N_Parameter_Specification
or else K = N_Object_Declaration
or else K = N_Discriminant_Specification
or else K = N_Allocator);
case K is
when N_Component_Declaration =>
Msg_K := Components;
Has_Null_Exclusion := Null_Exclusion_Present
(Component_Definition (N));
Typ := Etype (Subtype_Indication
(Component_Definition (N)));
Related_Nod := Subtype_Indication
(Component_Definition (N));
Msg_K := Components;
if not Present (Access_Definition (Component_Definition (N))) then
Has_Null_Exclusion := Null_Exclusion_Present
(Component_Definition (N));
Typ := Etype (Subtype_Indication (Component_Definition (N)));
Related_Nod := Subtype_Indication (Component_Definition (N));
Check_Must_Be_Access (Typ, Has_Null_Exclusion);
Check_Already_Null_Excluding_Type
(Typ, Has_Null_Exclusion, Related_Nod);
Check_Must_Be_Initialized (N, Related_Nod);
end if;
Check_Null_Not_Allowed (N);
when N_Parameter_Specification =>
Msg_K := Formals;
Msg_K := Formals;
Has_Null_Exclusion := Null_Exclusion_Present (N);
Typ := Entity (Parameter_Type (N));
Related_Nod := Parameter_Type (N);
Typ := Entity (Parameter_Type (N));
Related_Nod := Parameter_Type (N);
Check_Must_Be_Access (Typ, Has_Null_Exclusion);
Check_Already_Null_Excluding_Type
(Typ, Has_Null_Exclusion, Related_Nod);
Check_Null_Not_Allowed (N);
when N_Object_Declaration =>
Msg_K := Objects;
Msg_K := Objects;
Has_Null_Exclusion := Null_Exclusion_Present (N);
Typ := Entity (Object_Definition (N));
Related_Nod := Object_Definition (N);
Typ := Entity (Object_Definition (N));
Related_Nod := Object_Definition (N);
Check_Must_Be_Access (Typ, Has_Null_Exclusion);
Check_Already_Null_Excluding_Type
(Typ, Has_Null_Exclusion, Related_Nod);
Check_Must_Be_Initialized (N, Related_Nod);
Check_Null_Not_Allowed (N);
when N_Discriminant_Specification =>
Msg_K := Components;
Msg_K := Components;
if Nkind (Discriminant_Type (N)) = N_Access_Definition then
-- This case is special. We do not want to carry out some of
-- the null-excluding checks. Reason: the analysis of the
-- access_definition propagates the null-excluding attribute
-- to the can_never_be_null entity attribute (and thus it is
-- wrong to check it now)
Has_Null_Exclusion := False;
else
if Nkind (Discriminant_Type (N)) /= N_Access_Definition then
Has_Null_Exclusion := Null_Exclusion_Present (N);
Typ := Etype (Defining_Identifier (N));
Related_Nod := Discriminant_Type (N);
Check_Must_Be_Access (Typ, Has_Null_Exclusion);
Check_Already_Null_Excluding_Type
(Typ, Has_Null_Exclusion, Related_Nod);
end if;
Typ := Etype (Defining_Identifier (N));
Related_Nod := Discriminant_Type (N);
Check_Null_Not_Allowed (N);
when N_Allocator =>
Msg_K := Objects;
Msg_K := Objects;
Has_Null_Exclusion := Null_Exclusion_Present (N);
Typ := Etype (Expr);
Typ := Etype (Expression (N));
if Nkind (Expr) = N_Qualified_Expression then
Related_Nod := Subtype_Mark (Expr);
if Nkind (Expression (N)) = N_Qualified_Expression then
Related_Nod := Subtype_Mark (Expression (N));
else
Related_Nod := Expr;
Related_Nod := Expression (N);
end if;
Check_Must_Be_Access (Typ, Has_Null_Exclusion);
Check_Already_Null_Excluding_Type
(Typ, Has_Null_Exclusion, Related_Nod);
Check_Null_Not_Allowed (N);
when others =>
pragma Assert (False);
null;
end case;
-- Check that the entity was already decorated
pragma Assert (Typ /= Empty);
if Has_Null_Exclusion
and then not Is_Access_Type (Typ)
then
Error_Msg_N ("(Ada 0Y) must be an access type", Related_Nod);
elsif Has_Null_Exclusion
and then Can_Never_Be_Null (Typ)
then
Error_Msg_N
("(Ada 0Y) already a null-excluding type", Related_Nod);
elsif (Nkind (N) = N_Component_Declaration
or else Nkind (N) = N_Object_Declaration)
and not Present (Expr)
then
Must_Be_Initialized;
elsif Present (Expr)
and then Nkind (Expr) = N_Null
then
Null_Not_Allowed;
end if;
end Null_Exclusion_Static_Checks;
----------------------------------

26
gcc/ada/decl.c
View file

@ -1060,10 +1060,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|| Address_Taken (gnat_entity)
|| Is_Aliased (gnat_entity)
|| Is_Aliased (Etype (gnat_entity))))
SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl,
create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
gnu_expr, 0, Is_Public (gnat_entity), 0,
static_p, 0));
SET_DECL_CONST_CORRESPONDING_VAR
(gnu_decl,
create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
gnu_expr, 0, Is_Public (gnat_entity), 0,
static_p, 0));
/* If this is declared in a block that contains an block with an
exception handler, we must force this variable in memory to
@ -4407,8 +4408,15 @@ maybe_variable (tree gnu_operand, Node_Id gnat_node)
set_lineno (gnat_node, 1);
if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
return build1 (UNCONSTRAINED_ARRAY_REF, TREE_TYPE (gnu_operand),
variable_size (TREE_OPERAND (gnu_operand, 0)));
{
tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF,
TREE_TYPE (gnu_operand),
variable_size (TREE_OPERAND (gnu_operand, 0)));
TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
= TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
return gnu_result;
}
else
return variable_size (gnu_operand);
}
@ -4600,8 +4608,10 @@ make_packable_type (tree type)
TYPE_LEFT_JUSTIFIED_MODULAR_P (new_type)
= TYPE_LEFT_JUSTIFIED_MODULAR_P (type);
TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
if (TREE_CODE (type) == QUAL_UNION_TYPE)
if (TREE_CODE (type) == RECORD_TYPE)
TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
else if (TREE_CODE (type) == QUAL_UNION_TYPE)
{
TYPE_SIZE (new_type) = TYPE_SIZE (type);
TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);

13
gcc/ada/eval_fat.adb
View file

@ -83,9 +83,6 @@ package body Eval_Fat is
function Machine_Emin (RT : R) return Int;
-- Return value of the Machine_Emin attribute
function Machine_Mantissa (RT : R) return Nat;
-- Return value of the Machine_Mantissa attribute
--------------
-- Adjacent --
--------------
@ -706,6 +703,16 @@ package body Eval_Fat is
return Mant;
end Machine_Mantissa;
-------------------
-- Machine_Radix --
-------------------
function Machine_Radix (RT : R) return Nat is
pragma Warnings (Off, RT);
begin
return Radix;
end Machine_Radix;
-----------
-- Model --
-----------

4
gcc/ada/eval_fat.ads
View file

@ -66,6 +66,10 @@ package Eval_Fat is
function Leading_Part (RT : R; X : T; Radix_Digits : UI) return T;
function Machine_Mantissa (RT : R) return Nat;
function Machine_Radix (RT : R) return Nat;
function Model (RT : R; X : T) return T;
function Pred (RT : R; X : T) return T;

2
gcc/ada/exp_aggr.adb
View file

@ -1165,7 +1165,7 @@ package body Exp_Aggr is
Aggr_Low : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_L);
Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H);
-- After Duplicate_Subexpr these are side-effect free.
-- After Duplicate_Subexpr these are side-effect free
Low : Node_Id;
High : Node_Id;

8
gcc/ada/exp_attr.adb
View file

@ -3625,8 +3625,8 @@ package body Exp_Attr is
-- type(X)'Pos (X) >= 0
-- We can't quite generate it that way because of the requirement
-- for the non-standard second argument of False, so we have to
-- explicitly create:
-- for the non-standard second argument of False in the resulting
-- rep_to_pos call, so we have to explicitly create:
-- _rep_to_pos (X, False) >= 0
@ -3635,7 +3635,7 @@ package body Exp_Attr is
-- _rep_to_pos (X, False) >= 0
-- and then
-- (X >= type(X)'First and then type(X)'Last <= X)
-- (X >= type(X)'First and then type(X)'Last <= X)
elsif Is_Enumeration_Type (Ptyp)
and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp)))
@ -3710,7 +3710,7 @@ package body Exp_Attr is
-- But that's precisely what won't work because of possible
-- unwanted optimization (and indeed the basic motivation for
-- the Valid attribute -is exactly that this test does not work.
-- the Valid attribute is exactly that this test does not work!)
-- What will work is:
-- Btyp!(X) >= Btyp!(type(X)'First)

3
gcc/ada/exp_ch13.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -93,7 +93,6 @@ package body Exp_Ch13 is
declare
Decl : constant Node_Id := Declaration_Node (Ent);
begin
if Nkind (Decl) = N_Object_Declaration
and then Present (Expression (Decl))

14
gcc/ada/exp_ch4.adb
View file

@ -374,6 +374,7 @@ package body Exp_Ch4 is
-- We analyze by hand the new internal allocator to avoid
-- any recursion and inappropriate call to Initialize
if not Aggr_In_Place then
Remove_Side_Effects (Exp);
end if;
@ -2698,10 +2699,11 @@ package body Exp_Ch4 is
-----------------
procedure Expand_N_In (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Rtyp : constant Entity_Id := Etype (N);
Lop : constant Node_Id := Left_Opnd (N);
Rop : constant Node_Id := Right_Opnd (N);
Loc : constant Source_Ptr := Sloc (N);
Rtyp : constant Entity_Id := Etype (N);
Lop : constant Node_Id := Left_Opnd (N);
Rop : constant Node_Id := Right_Opnd (N);
Static : constant Boolean := Is_OK_Static_Expression (N);
begin
-- If we have an explicit range, do a bit of optimization based
@ -2717,11 +2719,14 @@ package body Exp_Ch4 is
begin
-- If either check is known to fail, replace result
-- by False, since the other check does not matter.
-- Preserve the static flag for legality checks, because
-- we are constant-folding beyond RM 4.9.
if Lcheck = LT or else Ucheck = GT then
Rewrite (N,
New_Reference_To (Standard_False, Loc));
Analyze_And_Resolve (N, Rtyp);
Set_Is_Static_Expression (N, Static);
return;
-- If both checks are known to succeed, replace result
@ -2731,6 +2736,7 @@ package body Exp_Ch4 is
Rewrite (N,
New_Reference_To (Standard_True, Loc));
Analyze_And_Resolve (N, Rtyp);
Set_Is_Static_Expression (N, Static);
return;
-- If lower bound check succeeds and upper bound check is

141
gcc/ada/exp_ch6.adb
View file

@ -1626,9 +1626,8 @@ package body Exp_Ch6 is
Get_Remotely_Callable
(Duplicate_Subexpr_Move_Checks (Actual))),
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
New_Occurrence_Of (RTE
(RE_Raise_Program_Error_For_E_4_18), Loc)))));
Make_Raise_Program_Error (Loc,
Reason => PE_Illegal_RACW_E_4_18))));
end if;
Next_Actual (Actual);
@ -2459,18 +2458,19 @@ package body Exp_Ch6 is
declare
Original_Assignment : constant Node_Id := Parent (N);
Saved_Assignment : constant Node_Id :=
Relocate_Node (Original_Assignment);
pragma Warnings (Off, Saved_Assignment);
begin
-- Preserve the original assignment node to keep the
-- complete assignment subtree consistent enough for
-- Analyze_Assignment to proceed. We do not use the
-- saved value, the point was just to do the relocation.
-- Analyze_Assignment to proceed (specifically, the
-- original Lhs node must still have an assignment
-- statement as its parent).
-- We cannot rely on Original_Node to go back from the
-- block node to the assignment node, because the
-- assignment might already be a rewrite substitution.
begin
Discard_Node (Relocate_Node (Original_Assignment));
Rewrite (Original_Assignment, Blk);
end;
@ -2766,11 +2766,16 @@ package body Exp_Ch6 is
----------------------------
procedure Expand_N_Function_Call (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Typ : constant Entity_Id := Etype (N);
function Returned_By_Reference return Boolean;
-- If the return type is returned through the secondary stack. that is
-- by reference, we don't want to create a temp to force stack checking.
-- Shouldn't this function be moved to exp_util???
---------------------------
-- Returned_By_Reference --
---------------------------
function Returned_By_Reference return Boolean is
S : Entity_Id := Current_Scope;
@ -2816,68 +2821,84 @@ package body Exp_Ch6 is
or else Expression (Parent (N)) /= N)
and then not Returned_By_Reference
then
-- Note: it might be thought that it would be OK to use a call to
-- Force_Evaluation here, but that's not good enough, because that
-- results in a 'Reference construct that may still need a temporary.
if Stack_Checking_Enabled then
declare
Loc : constant Source_Ptr := Sloc (N);
Temp_Obj : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('F'));
Temp_Typ : Entity_Id := Typ;
Decl : Node_Id;
A : Node_Id;
F : Entity_Id;
Proc : Entity_Id;
-- Note: it might be thought that it would be OK to use a call
-- to Force_Evaluation here, but that's not good enough, because
-- that can results in a 'Reference construct that may still
-- need a temporary.
begin
if Is_Tagged_Type (Typ)
and then Present (Controlling_Argument (N))
then
if Nkind (Parent (N)) /= N_Procedure_Call_Statement
and then Nkind (Parent (N)) /= N_Function_Call
declare
Loc : constant Source_Ptr := Sloc (N);
Temp_Obj : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('F'));
Temp_Typ : Entity_Id := Typ;
Decl : Node_Id;
A : Node_Id;
F : Entity_Id;
Proc : Entity_Id;
begin
if Is_Tagged_Type (Typ)
and then Present (Controlling_Argument (N))
then
-- If this is a tag-indeterminate call, the object must
-- be classwide.
if Nkind (Parent (N)) /= N_Procedure_Call_Statement
and then Nkind (Parent (N)) /= N_Function_Call
then
-- If this is a tag-indeterminate call, the object must
-- be classwide.
if Is_Tag_Indeterminate (N) then
Temp_Typ := Class_Wide_Type (Typ);
end if;
if Is_Tag_Indeterminate (N) then
Temp_Typ := Class_Wide_Type (Typ);
end if;
else
-- If this is a dispatching call that is itself the
-- controlling argument of an enclosing call, the nominal
-- subtype of the object that replaces it must be classwide,
-- so that dispatching will take place properly. If it is
-- not a controlling argument, the object is not classwide.
else
-- If this is a dispatching call that is itself the
-- controlling argument of an enclosing call, the
-- nominal subtype of the object that replaces it must
-- be classwide, so that dispatching will take place
-- properly. If it is not a controlling argument, the
-- object is not classwide.
Proc := Entity (Name (Parent (N)));
F := First_Formal (Proc);
A := First_Actual (Parent (N));
Proc := Entity (Name (Parent (N)));
F := First_Formal (Proc);
A := First_Actual (Parent (N));
while A /= N loop
Next_Formal (F);
Next_Actual (A);
end loop;
while A /= N loop
Next_Formal (F);
Next_Actual (A);
end loop;
if Is_Controlling_Formal (F) then
Temp_Typ := Class_Wide_Type (Typ);
if Is_Controlling_Formal (F) then
Temp_Typ := Class_Wide_Type (Typ);
end if;
end if;
end if;
end if;
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp_Obj,
Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
Constant_Present => True,
Expression => Relocate_Node (N));
Set_Assignment_OK (Decl);
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp_Obj,
Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
Constant_Present => True,
Expression => Relocate_Node (N));
Set_Assignment_OK (Decl);
Insert_Actions (N, New_List (Decl));
Rewrite (N, New_Occurrence_Of (Temp_Obj, Loc));
end;
Insert_Actions (N, New_List (Decl));
Rewrite (N, New_Occurrence_Of (Temp_Obj, Loc));
end;
else
-- If stack-checking is not enabled, increment serial number
-- for internal names, so that subsequent symbols are consistent
-- with and without stack-checking.
Synchronize_Serial_Number;
-- Now we can expand the call with consistent symbol names
Expand_Call (N);
end if;
-- Normal case, expand the call

4
gcc/ada/exp_ch9.adb
View file

@ -3282,10 +3282,11 @@ package body Exp_Ch9 is
Defining_Identifier => D_T2,
Type_Definition => Def1);
Analyze (Decl1);
Insert_After (N, Decl1);
-- Create Equivalent_Type, a record with two components for an
-- an access to object an an access to subprogram.
-- access to object and an access to subprogram.
Comps := New_List (
Make_Component_Declaration (Loc,
@ -3314,6 +3315,7 @@ package body Exp_Ch9 is
Make_Component_List (Loc,
Component_Items => Comps)));
Analyze (Decl2);
Insert_After (Decl1, Decl2);
Set_Equivalent_Type (T, E_T);
end Expand_Access_Protected_Subprogram_Type;

69
gcc/ada/exp_dbug.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1996-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -913,12 +913,7 @@ package body Exp_Dbug is
-- If we exit the loop then suffix must be output
if No_Dollar_In_Label then
Add_Str_To_Name_Buffer ("__");
else
Add_Char_To_Name_Buffer ('$');
end if;
Add_Str_To_Name_Buffer ("__");
Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len));
Homonym_Len := 0;
end if;
@ -1310,54 +1305,28 @@ package body Exp_Dbug is
-- Search for and strip homonym numbers suffix
-- Case of __ used for homonym numbers suffix
if No_Dollar_In_Label then
for J in reverse 2 .. Name_Len - 2 loop
if Name_Buffer (J) = '_'
and then Name_Buffer (J + 1) = '_'
then
if Name_Buffer (J + 2) in '0' .. '9' then
if Homonym_Len > 0 then
Homonym_Len := Homonym_Len + 1;
Homonym_Numbers (Homonym_Len) := '-';
end if;
SL := Name_Len - (J + 1);
Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) :=
Name_Buffer (J + 2 .. Name_Len);
Name_Len := J - 1;
Homonym_Len := Homonym_Len + SL;
for J in reverse 2 .. Name_Len - 2 loop
if Name_Buffer (J) = '_'
and then Name_Buffer (J + 1) = '_'
then
if Name_Buffer (J + 2) in '0' .. '9' then
if Homonym_Len > 0 then
Homonym_Len := Homonym_Len + 1;
Homonym_Numbers (Homonym_Len) := '-';
end if;
exit;
SL := Name_Len - (J + 1);
Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) :=
Name_Buffer (J + 2 .. Name_Len);
Name_Len := J - 1;
Homonym_Len := Homonym_Len + SL;
end if;
end loop;
-- Case of $ used for homonym numbers suffix
exit;
end if;
end loop;
else
for J in reverse 2 .. Name_Len - 1 loop
if Name_Buffer (J) = '$' then
if Name_Buffer (J + 1) in '0' .. '9' then
if Homonym_Len > 0 then
Homonym_Len := Homonym_Len + 1;
Homonym_Numbers (Homonym_Len) := '-';
end if;
SL := Name_Len - J;
Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) :=
Name_Buffer (J + 1 .. Name_Len);
Name_Len := J - 1;
Homonym_Len := Homonym_Len + SL;
end if;
exit;
end if;
end loop;
end if;
end Strip_Suffixes;
end Exp_Dbug;

59
gcc/ada/exp_dist.adb
View file

@ -80,6 +80,10 @@ package body Exp_Dist is
-- Local subprograms --
-----------------------
function Get_Subprogram_Id (E : Entity_Id) return Int;
-- Given a subprogram defined in a RCI package, get its subprogram id
-- which will be used for remote calls.
procedure Build_General_Calling_Stubs
(Decls : in List_Id;
Statements : in List_Id;
@ -2749,6 +2753,18 @@ package body Exp_Dist is
Make_Handled_Sequence_Of_Statements (Loc, Statements));
end Build_Subprogram_Calling_Stubs;
-------------------------
-- Build_Subprogram_Id --
-------------------------
function Build_Subprogram_Id
(Loc : Source_Ptr;
E : Entity_Id) return Node_Id
is
begin
return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
end Build_Subprogram_Id;
--------------------------------------
-- Build_Subprogram_Receiving_Stubs --
--------------------------------------
@ -2789,7 +2805,7 @@ package body Exp_Dist is
Excep_Code : List_Id;
Parameter_List : constant List_Id := New_List;
-- List of parameters to be passed to the subprogram.
-- List of parameters to be passed to the subprogram
Current_Parameter : Node_Id;
@ -3469,6 +3485,47 @@ package body Exp_Dist is
return End_String;
end Get_String_Id;
-----------------------
-- Get_Subprogram_Id --
-----------------------
function Get_Subprogram_Id (E : Entity_Id) return Int is
Current_Declaration : Node_Id;
Result : Int := 0;
begin
pragma Assert
(Is_Remote_Call_Interface (Scope (E))
and then
(Nkind (Parent (E)) = N_Procedure_Specification
or else
Nkind (Parent (E)) = N_Function_Specification));
Current_Declaration :=
First (Visible_Declarations
(Package_Specification_Of_Scope (Scope (E))));
while Current_Declaration /= Empty loop
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
if Defining_Unit_Name
(Specification (Current_Declaration)) = E
then
return Result;
end if;
Result := Result + 1;
end if;
Next (Current_Declaration);
end loop;
-- Error if we do not find it
raise Program_Error;
end Get_Subprogram_Id;
----------
-- Hash --
----------

7
gcc/ada/exp_dist.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -78,4 +78,9 @@ package Exp_Dist is
-- Build stub for a shared passive package. U is the analyzed
-- compilation unit for a package declaration.
function Build_Subprogram_Id
(Loc : Source_Ptr;
E : Entity_Id) return Node_Id;
-- Build a literal representing the remote subprogram identifier of E
end Exp_Dist;

4
gcc/ada/exp_intr.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -214,7 +214,7 @@ package body Exp_Intr is
Nam : Name_Id;
begin
-- If the intrinsic subprogram is generic, gets its original name.
-- If the intrinsic subprogram is generic, gets its original name
if Present (Parent (E))
and then Present (Generic_Parent (Parent (E)))

9
gcc/ada/exp_util.adb
View file

@ -3056,10 +3056,7 @@ package body Exp_Util is
function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
begin
if not Stack_Checking_Enabled then
return False;
elsif not Size_Known_At_Compile_Time (Typ) then
if not Size_Known_At_Compile_Time (Typ) then
return False;
elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
@ -3785,7 +3782,9 @@ package body Exp_Util is
-- in stack checking mode.
elsif Size_Known_At_Compile_Time (Otyp)
and then not May_Generate_Large_Temp (Otyp)
and then
(not Stack_Checking_Enabled
or else not May_Generate_Large_Temp (Otyp))
and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
then
return True;

19
gcc/ada/exp_util.ads
View file

@ -490,12 +490,13 @@ package Exp_Util is
function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean;
-- Determines if the given type, Typ, may require a large temporary
-- of the type that causes trouble if stack checking is enabled. The
-- result is True only if stack checking is enabled and the size of
-- the type is known at compile time and large, where large is defined
-- hueristically by the body of this routine. The purpose of this
-- routine is to help avoid generating troublesome temporaries that
-- intefere with the stack checking mechanism.
-- of the kind that causes back-end trouble if stack checking is enabled.
-- The result is True only the size of the type is known at compile time
-- and large, where large is defined heuristically by the body of this
-- routine. The purpose of this routine is to help avoid generating
-- troublesome temporaries that interfere with stack checking mechanism.
-- Note that the caller has to check whether stack checking is actually
-- enabled in order to guide the expansion (typically of a function call).
procedure Remove_Side_Effects
(Exp : Node_Id;
@ -505,14 +506,14 @@ package Exp_Util is
-- if necessary by an equivalent subexpression that is guaranteed to be
-- side effect free. This is done by extracting any actions that could
-- cause side effects, and inserting them using Insert_Actions into the
-- tree to which Exp is attached. Exp must be analayzed and resolved
-- tree to which Exp is attached. Exp must be analyzed and resolved
-- before the call and is analyzed and resolved on return. The Name_Req
-- may only be set to True if Exp has the form of a name, and the
-- effect is to guarantee that any replacement maintains the form of a
-- name. If Variable_Ref is set to TRUE, a variable is considered as a
-- side effect (used in implementing Force_Evaluation). Note: after a
-- call to Remove_Side_Effects, it is safe to use a call to
-- New_Copy_Tree to obtain a copy of the resulting expression.
-- call to Remove_Side_Effects, it is safe to call New_Copy_Tree to
-- obtain a copy of the resulting expression.
function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean;
-- Given the node for an N_Unchecked_Type_Conversion, return True

5
gcc/ada/get_targ.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -81,9 +81,6 @@ pragma Preelaborate (Get_Targ);
function Get_Maximum_Alignment return Pos;
pragma Import (C, Get_Maximum_Alignment, "get_target_maximum_alignment");
function Get_No_Dollar_In_Label return Boolean;
pragma Import (C, Get_No_Dollar_In_Label, "get_target_no_dollar_in_label");
function Get_Float_Words_BE return Nat;
pragma Import (C, Get_Float_Words_BE, "get_float_words_be");

5
gcc/ada/gnat_rm.texi
View file

@ -12565,8 +12565,9 @@ of the length corresponding to the @code{@var{type}'Size} value in Ada.
@noindent
The interface to C++ makes use of the following pragmas, which are
primarily intended to be constructed automatically using a binding generator
tool, although it is possible to construct them by hand. Ada Core
Technologies does not currently supply a suitable binding generator tool.
tool, although it is possible to construct them by hand. No suitable binding
generator tool is supplied with GNAT though.
Using these pragmas it is possible to achieve complete
inter-operability between Ada tagged types and C class definitions.

4
gcc/ada/gnatcmd.adb
View file

@ -278,7 +278,7 @@ procedure GNATCmd is
There_Are_Libraries : in out Boolean)
is
Path_Option : constant String_Access :=
MLib.Tgt.Linker_Library_Path_Option;
MLib.Linker_Library_Path_Option;
begin
-- Case of library project
@ -936,7 +936,7 @@ begin
declare
There_Are_Libraries : Boolean := False;
Path_Option : constant String_Access :=
MLib.Tgt.Linker_Library_Path_Option;
MLib.Linker_Library_Path_Option;
begin
Library_Paths.Set_Last (0);

37
gcc/ada/gnatlink.adb
View file

@ -42,6 +42,7 @@ with Ada.Command_Line; use Ada.Command_Line;
with Ada.Exceptions; use Ada.Exceptions;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with Interfaces.C.Strings; use Interfaces.C.Strings;
with System.CRTL;
procedure Gnatlink is
@ -121,8 +122,6 @@ procedure Gnatlink is
-- This table collects the arguments to be passed to compile the binder
-- generated file.
subtype chars_ptr is System.Address;
Gcc : String_Access := Program_Name ("gcc");
Read_Mode : constant String := "r" & ASCII.Nul;
@ -184,9 +183,6 @@ procedure Gnatlink is
procedure Process_Binder_File (Name : in String);
-- Reads the binder file and extracts linker arguments.
function Value (chars : chars_ptr) return String;
-- Return NUL-terminated string chars as an Ada string.
procedure Write_Header;
-- Show user the program name, version and copyright.
@ -652,18 +648,18 @@ procedure Gnatlink is
RB_Nlast : Integer; -- Slice last index
RB_Nfirst : Integer; -- Slice first index
Run_Path_Option_Ptr : Address;
Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
pragma Import (C, Run_Path_Option_Ptr, "run_path_option");
-- Pointer to string representing the native linker option which
-- specifies the path where the dynamic loader should find shared
-- libraries. Equal to null string if this system doesn't support it.
Object_Library_Ext_Ptr : Address;
Object_Library_Ext_Ptr : Interfaces.C.Strings.chars_ptr;
pragma Import (C, Object_Library_Ext_Ptr, "object_library_extension");
-- Pointer to string specifying the default extension for
-- object libraries, e.g. Unix uses ".a", VMS uses ".olb".
Object_File_Option_Ptr : Address;
Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr;
pragma Import (C, Object_File_Option_Ptr, "object_file_option");
-- Pointer to a string representing the linker option which specifies
-- the response file.
@ -1247,31 +1243,6 @@ procedure Gnatlink is
Status := fclose (Fd);
end Process_Binder_File;
-----------
-- Value --
-----------
function Value (chars : chars_ptr) return String is
function Strlen (chars : chars_ptr) return Natural;
pragma Import (C, Strlen);
begin
if chars = Null_Address then
return "";
else
declare
subtype Result_Type is String (1 .. Strlen (chars));
Result : Result_Type;
for Result'Address use chars;
begin
return Result;
end;
end if;
end Value;
------------------
-- Write_Header --
------------------

66
gcc/ada/gnatls.adb
View file

@ -37,9 +37,12 @@ with Opt; use Opt;
with Osint; use Osint;
with Osint.L; use Osint.L;
with Output; use Output;
with Rident; use Rident;
with Targparm; use Targparm;
with Types; use Types;
with GNAT.Case_Util; use GNAT.Case_Util;
procedure Gnatls is
pragma Ident (Gnat_Static_Version_String);
@ -147,7 +150,7 @@ procedure Gnatls is
-- Print out FS either in a coded form if verbose is false or in an
-- expanded form otherwise.
procedure Output_Unit (U_Id : Unit_Id);
procedure Output_Unit (ALI : ALI_Id; U_Id : Unit_Id);
-- Print out information on the unit when requested
procedure Reset_Print;
@ -159,6 +162,9 @@ procedure Gnatls is
procedure Usage;
-- Print usage message
function Image (Restriction : Restriction_Id) return String;
-- Returns the capitalized image of Restriction
-----------------
-- Add_Lib_Dir --
-----------------
@ -361,6 +367,31 @@ procedure Gnatls is
end if;
end Find_Status;
-----------
-- Image --
-----------
function Image (Restriction : Restriction_Id) return String is
Result : String := Restriction'Img;
Skip : Boolean := True;
begin
for J in Result'Range loop
if Skip then
Skip := False;
Result (J) := To_Upper (Result (J));
elsif Result (J) = '_' then
Skip := True;
else
Result (J) := To_Lower (Result (J));
end if;
end loop;
return Result;
end Image;
-------------------
-- Output_Object --
-------------------
@ -480,7 +511,7 @@ procedure Gnatls is
-- Output_Unit --
-----------------
procedure Output_Unit (U_Id : Unit_Id) is
procedure Output_Unit (ALI : ALI_Id; U_Id : Unit_Id) is
Kind : Character;
U : Unit_Record renames Units.Table (U_Id);
@ -604,6 +635,35 @@ procedure Gnatls is
end if;
end if;
declare
Restrictions : constant Restrictions_Info :=
ALIs.Table (ALI).Restrictions;
begin
-- If the source was compiled with pragmas Restrictions,
-- Display these restrictions.
if Restrictions.Set /= (All_Restrictions => False) then
Write_Eol; Write_Str (" Restrictions =>");
-- For boolean restrictions, just display the name of the
-- restriction; for valued restrictions, also display the
-- restriction value.
for Restriction in All_Restrictions loop
if Restrictions.Set (Restriction) then
Write_Eol;
Write_Str (" ");
Write_Str (Image (Restriction));
if Restriction in All_Parameter_Restrictions then
Write_Str (" =>");
Write_Str (Restrictions.Value (Restriction)'Img);
end if;
end if;
end loop;
end if;
end;
end if;
if Print_Source then
@ -1049,7 +1109,7 @@ begin
Write_Eol;
end if;
Output_Unit (U);
Output_Unit (Id, U);
-- Output source now, unless if it will be done as part of
-- outputing dependencies.

6
gcc/ada/layout.adb
View file

@ -993,6 +993,12 @@ package body Layout is
Decl := Parent (Parent (Entity (N)));
Size := (Discrim, Size.Nod);
Vtyp := Defining_Identifier (Decl);
-- Ensure that we get a private type's full type
if Present (Underlying_Type (Vtyp)) then
Vtyp := Underlying_Type (Vtyp);
end if;
end if;
Typ := Etype (N);

10
gcc/ada/lib.adb
View file

@ -945,6 +945,16 @@ package body Lib is
(Option => S, Unit => Current_Sem_Unit);
end Store_Linker_Option_String;
-------------------------------
-- Synchronize_Serial_Number --
-------------------------------
procedure Synchronize_Serial_Number is
TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
begin
TSN := TSN + 1;
end Synchronize_Serial_Number;
---------------
-- Tree_Read --
---------------

9
gcc/ada/lib.ads
View file

@ -527,6 +527,15 @@ package Lib is
-- Increment Serial_Number field for current unit, and return the
-- incremented value.
procedure Synchronize_Serial_Number;
-- This function increments the Serial_Number field for the current
-- unit but does not return the incremented value. This is used when
-- there is a situation where one path of control increments a serial
-- number (using Increment_Serial_Number), and the other path does not
-- and it is important to keep the serial numbers synchronized in the
-- two cases (e.g. when the references in a package and a client must
-- be kept consistent).
procedure Replace_Linker_Option_String
(S : String_Id; Match_String : String);
-- Replace an existing Linker_Option if the prefix Match_String

2
gcc/ada/link.c
View file

@ -147,7 +147,7 @@ const char *object_library_extension = ".olb";
#elif defined (sun)
const char *object_file_option = "";
const char *run_path_option = "-R";
const char *run_path_option = "-Wl,-R,";
char shared_libgnat_default = STATIC;
int link_max = 2147483647;
unsigned char objlist_file_supported = 0;

357
gcc/ada/make.adb
View file

@ -35,6 +35,7 @@ with Fname.UF; use Fname.UF;
with Gnatvsn; use Gnatvsn;
with Hostparm; use Hostparm;
with Makeusg;
with Makeutl; use Makeutl;
with MLib.Prj;
with MLib.Tgt; use MLib.Tgt;
with MLib.Utl;
@ -47,7 +48,6 @@ with Output; use Output;
with Prj; use Prj;
with Prj.Com;
with Prj.Env;
with Prj.Ext;
with Prj.Pars;
with Prj.Util;
with SFN_Scan;
@ -180,30 +180,6 @@ package body Make is
Table_Name => "Make.Q");
-- This is the actual Q.
-- Package Mains is used to store the mains specified on the command line
-- and to retrieve them when a project file is used, to verify that the
-- files exist and that they belong to a project file.
package Mains is
-- Mains are stored in a table. An index is used to retrieve the mains
-- from the table.
procedure Add_Main (Name : String);
-- Add one main to the table
procedure Delete;
-- Empty the table
procedure Reset;
-- Reset the index to the beginning of the table
function Next_Main return String;
-- Increase the index and return the next main.
-- If table is exhausted, return an empty string.
end Mains;
-- The following instantiations and variables are necessary to save what
-- is found on the command line, in case there is a project file specified.
@ -271,19 +247,6 @@ package body Make is
Table_Increment => 100,
Table_Name => "Make.Library_Projs");
type Linker_Options_Data is record
Project : Project_Id;
Options : String_List_Id;
end record;
package Linker_Opts is new Table.Table (
Table_Component_Type => Linker_Options_Data,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Make.Linker_Opts");
-- Two variables to keep the last binder and linker switch index
-- in tables Binder_Switches and Linker_Switches, before adding
-- switches from the project file (if any) and switches from the
@ -588,16 +551,6 @@ package body Make is
-- Check what steps (Compile, Bind, Link) must be executed.
-- Set the step flags accordingly.
function Is_External_Assignment (Argv : String) return Boolean;
-- Verify that an external assignment switch is syntactically correct.
-- Correct forms are
-- -Xname=value
-- -X"name=other value"
-- Assumptions: 'First = 1, Argv (1 .. 2) = "-X"
-- When this function returns True, the external assignment has
-- been entered by a call to Prj.Ext.Add, so that in a project
-- file, External ("name") will return "value".
function In_Ada_Lib_Dir (File : File_Name_Type) return Boolean;
-- Get directory prefix of this file and get lib mark stored in name
-- table for this directory. Then check if an Ada lib mark has been set.
@ -628,16 +581,6 @@ package body Make is
-- the extension ".ali". If there is no switches for either names, try the
-- default switches for Ada. If all failed, return No_Variable_Value.
procedure Test_If_Relative_Path
(Switch : in out String_Access;
Parent : String_Access;
Including_L_Switch : Boolean := True);
-- Test if Switch is a relative search path switch.
-- If it is, fail if Parent is null, otherwise prepend the path with
-- Parent. This subprogram is only called when using project files.
-- For gnatbind switches, Including_L_Switch is False, because the
-- argument of the -L switch is not a path.
function Is_In_Object_Directory
(Source_File : File_Name_Type;
Full_Lib_File : File_Name_Type) return Boolean;
@ -3562,16 +3505,21 @@ package body Make is
Normalize_Pathname
(Real_Path.all,
Case_Sensitive => False);
Proj_Path : constant String :=
Normalize_Pathname
(Project_Path,
Case_Sensitive => False);
begin
Free (Real_Path);
-- Fail if it is not the correct path
if Normed_Path /= Project_Path then
if Normed_Path /= Proj_Path then
if Verbose_Mode then
Write_Str (Normed_Path);
Write_Str (" /= ");
Write_Line (Project_Path);
Write_Line (Proj_Path);
end if;
Make_Failed
@ -4963,7 +4911,7 @@ package body Make is
There_Are_Libraries : Boolean := False;
Linker_Switches_Last : constant Integer := Linker_Switches.Last;
Path_Option : constant String_Access :=
MLib.Tgt.Linker_Library_Path_Option;
MLib.Linker_Library_Path_Option;
Current : Natural;
Proj2 : Project_Id;
Depth : Natural;
@ -5118,95 +5066,14 @@ package body Make is
-- other than the main project
declare
Linker_Package : Package_Id;
Options : Variable_Value;
Linker_Options : constant String_List :=
Linker_Options_Switches (Main_Project);
begin
Linker_Opts.Init;
for Index in 1 .. Projects.Last loop
if Index /= Main_Project then
Linker_Package :=
Prj.Util.Value_Of
(Name => Name_Linker,
In_Packages =>
Projects.Table (Index).Decl.Packages);
Options :=
Prj.Util.Value_Of
(Name => Name_Ada,
Attribute_Or_Array_Name => Name_Linker_Options,
In_Package => Linker_Package);
-- If attribute is present, add the project with
-- the attribute to table Linker_Opts.
if Options /= Nil_Variable_Value then
Linker_Opts.Increment_Last;
Linker_Opts.Table (Linker_Opts.Last) :=
(Project => Index, Options => Options.Values);
end if;
end if;
end loop;
end;
declare
Opt1 : Linker_Options_Data;
Opt2 : Linker_Options_Data;
Depth : Natural;
Options : String_List_Id;
Option : Name_Id;
begin
-- Sort the project by increasing depths
for Index in 1 .. Linker_Opts.Last loop
Opt1 := Linker_Opts.Table (Index);
Depth := Projects.Table (Opt1.Project).Depth;
for J in Index + 1 .. Linker_Opts.Last loop
Opt2 := Linker_Opts.Table (J);
if
Projects.Table (Opt2.Project).Depth < Depth
then
Linker_Opts.Table (Index) := Opt2;
Linker_Opts.Table (J) := Opt1;
Opt1 := Opt2;
Depth :=
Projects.Table (Opt1.Project).Depth;
end if;
end loop;
-- If Dir_Path has not been computed for this project,
-- do it now.
if Projects.Table (Opt1.Project).Dir_Path = null then
Projects.Table (Opt1.Project).Dir_Path :=
new String'
(Get_Name_String
(Projects.Table (Opt1.Project). Directory));
end if;
Options := Opt1.Options;
-- Add each of the options to the linker switches
while Options /= Nil_String loop
Option := String_Elements.Table (Options).Value;
Options := String_Elements.Table (Options).Next;
Linker_Switches.Increment_Last;
Linker_Switches.Table (Linker_Switches.Last) :=
new String'(Get_Name_String (Option));
-- Object files and -L switches specified with
-- relative paths and must be converted to
-- absolute paths.
Test_If_Relative_Path
(Switch =>
Linker_Switches.Table (Linker_Switches.Last),
Parent => Projects.Table (Opt1.Project).Dir_Path,
Including_L_Switch => True);
end loop;
for Option in Linker_Options'Range loop
Linker_Switches.Increment_Last;
Linker_Switches.Table (Linker_Switches.Last) :=
Linker_Options (Option);
end loop;
end;
end if;
@ -5781,9 +5648,9 @@ package body Make is
Marking_Label := 1;
end Initialize;
-----------------------------------
-- Insert_Project_Sources_Into_Q --
-----------------------------------
----------------------------
-- Insert_Project_Sources --
----------------------------
procedure Insert_Project_Sources
(The_Project : Project_Id;
@ -5962,47 +5829,6 @@ package body Make is
Q.Increment_Last;
end Insert_Q;
----------------------------
-- Is_External_Assignment --
----------------------------
function Is_External_Assignment (Argv : String) return Boolean is
Start : Positive := 3;
Finish : Natural := Argv'Last;
Equal_Pos : Natural;
begin
if Argv'Last < 5 then
return False;
elsif Argv (3) = '"' then
if Argv (Argv'Last) /= '"' or else Argv'Last < 7 then
return False;
else
Start := 4;
Finish := Argv'Last - 1;
end if;
end if;
Equal_Pos := Start;
while Equal_Pos <= Finish and then Argv (Equal_Pos) /= '=' loop
Equal_Pos := Equal_Pos + 1;
end loop;
if Equal_Pos = Start
or else Equal_Pos >= Finish
then
return False;
else
Prj.Ext.Add
(External_Name => Argv (Start .. Equal_Pos - 1),
Value => Argv (Equal_Pos + 1 .. Finish));
return True;
end if;
end Is_External_Assignment;
---------------------
-- Is_In_Obsoleted --
---------------------
@ -6245,68 +6071,6 @@ package body Make is
Set_Standard_Error;
end List_Depend;
-----------
-- Mains --
-----------
package body Mains is
package Names is new Table.Table
(Table_Component_Type => File_Name_Type,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Make.Mains.Names");
-- The table that stores the main
Current : Natural := 0;
-- The index of the last main retrieved from the table
--------------
-- Add_Main --
--------------
procedure Add_Main (Name : String) is
begin
Name_Len := 0;
Add_Str_To_Name_Buffer (Name);
Names.Increment_Last;
Names.Table (Names.Last) := Name_Find;
end Add_Main;
------------
-- Delete --
------------
procedure Delete is
begin
Names.Set_Last (0);
Reset;
end Delete;
---------------
-- Next_Main --
---------------
function Next_Main return String is
begin
if Current >= Names.Last then
return "";
else
Current := Current + 1;
return Get_Name_String (Names.Table (Current));
end if;
end Next_Main;
procedure Reset is
begin
Current := 0;
end Reset;
end Mains;
----------
-- Mark --
----------
@ -6979,6 +6743,7 @@ package body Make is
-- unless we are dealing with a debug switch (starts with 'd')
elsif Argv (2) /= 'd'
and then Argv (2) /= 'e'
and then Argv (2 .. Argv'Last) /= "C"
and then Argv (2 .. Argv'Last) /= "F"
and then Argv (2 .. Argv'Last) /= "M"
@ -7099,85 +6864,6 @@ package body Make is
return Switches;
end Switches_Of;
---------------------------
-- Test_If_Relative_Path --
---------------------------
procedure Test_If_Relative_Path
(Switch : in out String_Access;
Parent : String_Access;
Including_L_Switch : Boolean := True)
is
begin
if Switch /= null then
declare
Sw : String (1 .. Switch'Length);
Start : Positive;
begin
Sw := Switch.all;
if Sw (1) = '-' then
if Sw'Length >= 3
and then (Sw (2) = 'A'
or else Sw (2) = 'I'
or else (Including_L_Switch and then Sw (2) = 'L'))
then
Start := 3;
if Sw = "-I-" then
return;
end if;
elsif Sw'Length >= 4
and then (Sw (2 .. 3) = "aL"
or else Sw (2 .. 3) = "aO"
or else Sw (2 .. 3) = "aI")
then
Start := 4;
else
return;
end if;
-- Because relative path arguments to --RTS= may be relative
-- to the search directory prefix, those relative path
-- arguments are not converted.
if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
if Parent = null or else Parent'Length = 0 then
Make_Failed
("relative search path switches (""",
Sw,
""") are not allowed");
else
Switch :=
new String'
(Sw (1 .. Start - 1) &
Parent.all &
Directory_Separator &
Sw (Start .. Sw'Last));
end if;
end if;
else
if not Is_Absolute_Path (Sw) then
if Parent = null or else Parent'Length = 0 then
Make_Failed
("relative paths (""", Sw, """) are not allowed");
else
Switch :=
new String'(Parent.all & Directory_Separator & Sw);
end if;
end if;
end if;
end;
end if;
end Test_If_Relative_Path;
-----------
-- Usage --
-----------
@ -7225,6 +6911,7 @@ package body Make is
begin
-- Make sure that in case of failure, the temp files will be deleted
Prj.Com.Fail := Make_Failed'Access;
MLib.Fail := Make_Failed'Access;
Prj.Com.Fail := Make_Failed'Access;
MLib.Fail := Make_Failed'Access;
Makeutl.Do_Fail := Make_Failed'Access;
end Make;

8
gcc/ada/makeusg.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -88,6 +88,12 @@ begin
Write_Str (" -D dir Specify dir as the object directory");
Write_Eol;
-- Line for -eL
Write_Str (" -eL Follow symbolic links when processing " &
"project files");
Write_Eol;
-- Line for -f
Write_Str (" -f Force recompilations of non predefined units");

61
gcc/ada/mdll-utl.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -308,53 +308,60 @@ package body MDLL.Utl is
begin
-- dlltool
Dlltool_Exec := OS_Lib.Locate_Exec_On_Path (Dlltool_Name);
if Dlltool_Exec = null then
Exceptions.Raise_Exception
(Tools_Error'Identity, Dlltool_Name & " not found in path");
Dlltool_Exec := OS_Lib.Locate_Exec_On_Path (Dlltool_Name);
elsif Verbose then
Text_IO.Put_Line ("using " & Dlltool_Exec.all);
if Dlltool_Exec = null then
Exceptions.Raise_Exception
(Tools_Error'Identity, Dlltool_Name & " not found in path");
elsif Verbose then
Text_IO.Put_Line ("using " & Dlltool_Exec.all);
end if;
end if;
-- gcc
Gcc_Exec := OS_Lib.Locate_Exec_On_Path (Gcc_Name);
if Gcc_Exec = null then
Exceptions.Raise_Exception
(Tools_Error'Identity, Gcc_Name & " not found in path");
Gcc_Exec := OS_Lib.Locate_Exec_On_Path (Gcc_Name);
elsif Verbose then
Text_IO.Put_Line ("using " & Gcc_Exec.all);
if Gcc_Exec = null then
Exceptions.Raise_Exception
(Tools_Error'Identity, Gcc_Name & " not found in path");
elsif Verbose then
Text_IO.Put_Line ("using " & Gcc_Exec.all);
end if;
end if;
-- gnatbind
Gnatbind_Exec := OS_Lib.Locate_Exec_On_Path (Gnatbind_Name);
if Gnatbind_Exec = null then
Exceptions.Raise_Exception
(Tools_Error'Identity, Gnatbind_Name & " not found in path");
Gnatbind_Exec := OS_Lib.Locate_Exec_On_Path (Gnatbind_Name);
elsif Verbose then
Text_IO.Put_Line ("using " & Gnatbind_Exec.all);
if Gnatbind_Exec = null then
Exceptions.Raise_Exception
(Tools_Error'Identity, Gnatbind_Name & " not found in path");
elsif Verbose then
Text_IO.Put_Line ("using " & Gnatbind_Exec.all);
end if;
end if;
-- gnatlink
Gnatlink_Exec := OS_Lib.Locate_Exec_On_Path (Gnatlink_Name);
if Gnatlink_Exec = null then
Exceptions.Raise_Exception
(Tools_Error'Identity, Gnatlink_Name & " not found in path");
Gnatlink_Exec := OS_Lib.Locate_Exec_On_Path (Gnatlink_Name);
elsif Verbose then
Text_IO.Put_Line ("using " & Gnatlink_Exec.all);
Text_IO.New_Line;
if Gnatlink_Exec = null then
Exceptions.Raise_Exception
(Tools_Error'Identity, Gnatlink_Name & " not found in path");
elsif Verbose then
Text_IO.Put_Line ("using " & Gnatlink_Exec.all);
Text_IO.New_Line;
end if;
end if;
end Locate;
end MDLL.Utl;

25
gcc/ada/mlib-prj.adb
View file

@ -308,9 +308,6 @@ package body MLib.Prj is
Libdecgnat_Needed : Boolean := False;
-- On OpenVMS, set to True if library needs to be linked with libdecgnat
Check_Libdecgnat : Boolean := Hostparm.OpenVMS;
-- Set to False if package Dec is part of the library sources.
Data : Project_Data := Projects.Table (For_Project);
Object_Directory_Path : constant String :=
@ -375,8 +372,7 @@ package body MLib.Prj is
-- to link with -lgnarl (this is the case when there is a dependency
-- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file
-- indicates that there is a need to link with -ldecgnat (this is the
-- case when there is a dependency on dec.ads, except when it is the
-- DEC library, the one that contains package DEC).
-- case when there is a dependency on dec.ads).
procedure Process (The_ALI : File_Name_Type);
-- Check if the closure of a library unit which is or should be in the
@ -509,16 +505,8 @@ package body MLib.Prj is
Id : ALI.ALI_Id;
begin
-- On OpenVMS, if we have package DEC, it means this is the DEC lib:
-- no need to link with itself.
if Check_Libdecgnat and then ALI_File = "dec.ali" then
Check_Libdecgnat := False;
Libdecgnat_Needed := False;
end if;
if not Libgnarl_Needed or
(Check_Libdecgnat and then (not Libdecgnat_Needed))
(Hostparm.OpenVMS and then (not Libdecgnat_Needed))
then
-- Scan the ALI file
@ -535,7 +523,7 @@ package body MLib.Prj is
Read_Lines => "D");
Free (Text);
-- Look for s-osinte.ads and dec.ads in the dependencies
-- Look for s-osinte.ads in the dependencies
for Index in ALI.ALIs.Table (Id).First_Sdep ..
ALI.ALIs.Table (Id).Last_Sdep
@ -543,7 +531,7 @@ package body MLib.Prj is
if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then
Libgnarl_Needed := True;
elsif Check_Libdecgnat and then
elsif Hostparm.OpenVMS and then
ALI.Sdep.Table (Index).Sfile = S_Dec_Ads
then
Libdecgnat_Needed := True;
@ -1950,10 +1938,7 @@ package body MLib.Prj is
end if;
Status := fclose (Fd);
-- It is safe to ignore any error when closing, because the file was
-- only opened for reading.
-- Is it really right to ignore any close error ???
end Process_Binder_File;
------------------

9
gcc/ada/mlib-tgt.adb
View file

@ -190,15 +190,6 @@ package body MLib.Tgt is
return No_Name;
end Library_File_Name_For;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
function Linker_Library_Path_Option return String_Access is
begin
return null;
end Linker_Library_Path_Option;
----------------
-- Object_Ext --
----------------

5
gcc/ada/mlib-tgt.ads
View file

@ -101,11 +101,6 @@ package MLib.Tgt is
function Is_Archive_Ext (Ext : String) return Boolean;
-- Returns True iff Ext is an extension for a library
function Linker_Library_Path_Option return String_Access;
-- Linker option to specify to the linker the library directory path.
-- If non null, the library directory path is to be appended.
-- Should be deallocated by the caller, when no longer needed.
procedure Build_Dynamic_Library
(Ofiles : Argument_List;
Foreign : Argument_List;

33
gcc/ada/mlib.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2003, Ada Core Technologies, Inc. --
-- Copyright (C) 1999-2004, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -25,6 +25,7 @@
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Interfaces.C.Strings;
with Hostparm;
with Opt;
@ -40,6 +41,9 @@ with System;
package body MLib is
pragma Linker_Options ("link.o");
-- For run_path_option string.
-------------------
-- Build_Library --
-------------------
@ -285,13 +289,34 @@ package body MLib is
end if;
end Copy_ALI_Files;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
function Linker_Library_Path_Option return String_Access is
Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
pragma Import (C, Run_Path_Option_Ptr, "run_path_option");
-- Pointer to string representing the native linker option which
-- specifies the path where the dynamic loader should find shared
-- libraries. Equal to null string if this system doesn't support it.
S : constant String := Interfaces.C.Strings.Value (Run_Path_Option_Ptr);
begin
if S'Length = 0 then
return null;
else
return new String'(S);
end if;
end Linker_Library_Path_Option;
-- Package elaboration
begin
-- Copy_Attributes always fails on VMS
if Hostparm.OpenVMS then
-- Copy_Attributes always fails on VMS
Preserve := None;
end if;
end MLib;

7
gcc/ada/mlib.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2003, Ada Core Technologies, Inc. --
-- Copyright (C) 1999-2004, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -65,6 +65,11 @@ package MLib is
-- Copy all ALI files Files to directory To.
-- Mark Interfaces ALI files as interfaces, if any.
function Linker_Library_Path_Option return String_Access;
-- Linker option to specify to the linker the library directory path.
-- If non null, the library directory path is to be appended.
-- Should be deallocated by the caller, when no longer needed.
private
Preserve : Attribute := Time_Stamps;

4
gcc/ada/opt.ads
View file

@ -526,6 +526,10 @@ package Opt is
-- then elaboration flag checks are to be generated in the binder
-- generated file.
Follow_Links : Boolean := False;
-- GNATMAKE
-- Set to True (-eL) to process the project files in trusted mode
Front_End_Inlining : Boolean := False;
-- GNAT
-- Set True to activate inlining by front-end expansion.

289
gcc/ada/par-ch3.adb
View file

@ -741,10 +741,8 @@ package body Ch3 is
Scan; -- past NEW
end if;
if Extensions_Allowed then -- Ada 0Y (AI-231)
Not_Null_Present := P_Null_Exclusion;
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
end if;
Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Subtype_Indication
(Decl_Node, P_Subtype_Indication (Not_Null_Present));
@ -1293,7 +1291,6 @@ package body Ch3 is
else
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Constant_Present (Decl_Node, True);
if Token_Name = Name_Aliased then
@ -1312,10 +1309,8 @@ package body Ch3 is
(Decl_Node, P_Array_Type_Definition);
else
if Extensions_Allowed then -- Ada 0Y (AI-231)
Not_Null_Present := P_Null_Exclusion;
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
end if;
Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Object_Definition (Decl_Node,
P_Subtype_Indication (Not_Null_Present));
@ -1351,7 +1346,6 @@ package body Ch3 is
Scan; -- past ALIASED
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Aliased_Present (Decl_Node, True);
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
if Token = Tok_Constant then
Scan; -- past CONSTANT
@ -1363,11 +1357,8 @@ package body Ch3 is
(Decl_Node, P_Array_Type_Definition);
else
if Extensions_Allowed then -- Ada 0Y (AI-231)
Not_Null_Present := P_Null_Exclusion;
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
end if;
Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Object_Definition (Decl_Node,
P_Subtype_Indication (Not_Null_Present));
end if;
@ -1378,6 +1369,74 @@ package body Ch3 is
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
-- Ada 0Y (AI-254)
elsif Token = Tok_Not then
-- OBJECT_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
-- OBJECT_RENAMING_DECLARATION ::=
-- ...
-- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
if Token = Tok_Access then
if not Extensions_Allowed then
Error_Msg_SP
("generalized use of anonymous access types " &
"is an Ada 0Y extension");
Error_Msg_SP ("\unit must be compiled with -gnatX switch");
end if;
Acc_Node := P_Access_Definition (Not_Null_Present);
if Token /= Tok_Renames then
Error_Msg_SC ("'RENAMES' expected");
raise Error_Resync;
end if;
Scan; -- past renames
No_List;
Decl_Node :=
New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
Set_Access_Definition (Decl_Node, Acc_Node);
Set_Name (Decl_Node, P_Name);
else
Type_Node := P_Subtype_Mark;
-- Object renaming declaration
if Token_Is_Renames then
Error_Msg_SP ("(Ada 0Y) null-exclusion not allowed in "
& "object renamings");
raise Error_Resync;
-- Object declaration
else
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Object_Definition
(Decl_Node,
P_Subtype_Indication (Type_Node, Not_Null_Present));
-- RENAMES at this point means that we had the combination
-- of a constraint on the Type_Node and renames, which is
-- illegal
if Token_Is_Renames then
Error_Msg_N ("constraint not allowed in object renaming "
& "declaration",
Constraint (Object_Definition (Decl_Node)));
raise Error_Resync;
end if;
end if;
end if;
-- Ada 0Y (AI-230): Access Definition case
elsif Token = Tok_Access then
@ -1388,7 +1447,7 @@ package body Ch3 is
Error_Msg_SP ("\unit must be compiled with -gnatX switch");
end if;
Acc_Node := P_Access_Definition;
Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
if Token /= Tok_Renames then
Error_Msg_SC ("'RENAMES' expected");
@ -1405,20 +1464,11 @@ package body Ch3 is
-- Subtype indication case
else
if Extensions_Allowed then -- Ada 0Y (AI-231)
Not_Null_Present := P_Null_Exclusion;
end if;
Type_Node := P_Subtype_Mark;
-- Object renaming declaration
if Token_Is_Renames then
if Not_Null_Present then
Error_Msg_SP
("(Ada 0Y) null-exclusion not allowed in renamings");
end if;
No_List;
Decl_Node :=
New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
@ -1551,11 +1601,8 @@ package body Ch3 is
Scan;
end if;
if Extensions_Allowed then -- Ada 0Y (AI-231)
Not_Null_Present := P_Null_Exclusion;
Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
end if;
Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
Set_Subtype_Indication (Typedef_Node,
P_Subtype_Indication (Not_Null_Present));
@ -2130,6 +2177,7 @@ package body Ch3 is
Not_Null_Present : Boolean := False;
Subs_List : List_Id;
Scan_State : Saved_Scan_State;
Aliased_Present : Boolean := False;
begin
Array_Loc := Token_Ptr;
@ -2189,6 +2237,17 @@ package body Ch3 is
CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
if Token_Name = Name_Aliased then
Check_95_Keyword (Tok_Aliased, Tok_Identifier);
end if;
if Token = Tok_Aliased then
Aliased_Present := True;
Scan; -- past ALIASED
end if;
Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231/AI-254)
-- Ada 0Y (AI-230): Access Definition case
if Token = Tok_Access then
@ -2199,28 +2258,21 @@ package body Ch3 is
Error_Msg_SP ("\unit must be compiled with -gnatX switch");
end if;
Set_Subtype_Indication (CompDef_Node, Empty);
Set_Aliased_Present (CompDef_Node, False);
Set_Access_Definition (CompDef_Node, P_Access_Definition);
if Aliased_Present then
Error_Msg_SP ("ALIASED not allowed here");
end if;
Set_Subtype_Indication (CompDef_Node, Empty);
Set_Aliased_Present (CompDef_Node, False);
Set_Access_Definition (CompDef_Node,
P_Access_Definition (Not_Null_Present));
else
Set_Access_Definition (CompDef_Node, Empty);
if Token_Name = Name_Aliased then
Check_95_Keyword (Tok_Aliased, Tok_Identifier);
end if;
if Token = Tok_Aliased then
Set_Aliased_Present (CompDef_Node, True);
Scan; -- past ALIASED
end if;
if Extensions_Allowed then -- Ada 0Y (AI-231)
Not_Null_Present := P_Null_Exclusion;
Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
end if;
Set_Subtype_Indication (CompDef_Node,
P_Subtype_Indication (Not_Null_Present));
Set_Access_Definition (CompDef_Node, Empty);
Set_Aliased_Present (CompDef_Node, Aliased_Present);
Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
Set_Subtype_Indication (CompDef_Node,
P_Subtype_Indication (Not_Null_Present));
end if;
Set_Component_Definition (Def_Node, CompDef_Node);
@ -2444,7 +2496,6 @@ package body Ch3 is
Specification_Node :=
New_Node (N_Discriminant_Specification, Ident_Sloc);
Set_Defining_Identifier (Specification_Node, Idents (Ident));
Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
if Token = Tok_Access then
@ -2454,11 +2505,10 @@ package body Ch3 is
end if;
Set_Discriminant_Type
(Specification_Node, P_Access_Definition);
Set_Null_Exclusion_Present -- Ada 0Y (AI-231)
(Discriminant_Type (Specification_Node),
Not_Null_Present);
(Specification_Node,
P_Access_Definition (Not_Null_Present));
else
Set_Discriminant_Type
(Specification_Node, P_Subtype_Mark);
No_Constraint;
@ -2876,6 +2926,7 @@ package body Ch3 is
-- items, do we need to add this capability sometime in the future ???
procedure P_Component_Items (Decls : List_Id) is
Aliased_Present : Boolean := False;
CompDef_Node : Node_Id;
Decl_Node : Node_Id;
Scan_State : Saved_Scan_State;
@ -2935,6 +2986,19 @@ package body Ch3 is
CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
if Token_Name = Name_Aliased then
Check_95_Keyword (Tok_Aliased, Tok_Identifier);
end if;
if Token = Tok_Aliased then
Aliased_Present := True;
Scan; -- past ALIASED
end if;
Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231/AI-254)
-- Ada 0Y (AI-230): Access Definition case
if Token = Tok_Access then
if not Extensions_Allowed then
Error_Msg_SP
@ -2943,21 +3007,19 @@ package body Ch3 is
Error_Msg_SP ("\unit must be compiled with -gnatX switch");
end if;
if Aliased_Present then
Error_Msg_SP ("ALIASED not allowed here");
end if;
Set_Subtype_Indication (CompDef_Node, Empty);
Set_Aliased_Present (CompDef_Node, False);
Set_Access_Definition (CompDef_Node, P_Access_Definition);
Set_Access_Definition (CompDef_Node,
P_Access_Definition (Not_Null_Present));
else
Set_Access_Definition (CompDef_Node, Empty);
if Token_Name = Name_Aliased then
Check_95_Keyword (Tok_Aliased, Tok_Identifier);
end if;
if Token = Tok_Aliased then
Scan; -- past ALIASED
Set_Aliased_Present (CompDef_Node, True);
end if;
Set_Access_Definition (CompDef_Node, Empty);
Set_Aliased_Present (CompDef_Node, Aliased_Present);
Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
if Token = Tok_Array then
Error_Msg_SC
@ -2965,13 +3027,8 @@ package body Ch3 is
raise Error_Resync;
end if;
if Extensions_Allowed then -- Ada 0Y (AI-231)
Not_Null_Present := P_Null_Exclusion;
Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
end if;
Set_Subtype_Indication (CompDef_Node,
P_Subtype_Indication (Not_Null_Present));
P_Subtype_Indication (Not_Null_Present));
end if;
Set_Component_Definition (Decl_Node, CompDef_Node);
@ -3231,15 +3288,18 @@ package body Ch3 is
-- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
-- The caller has checked that the initial token is ACCESS
-- Ada 0Y (AI-254): If Header_Already_Parsed then the caller has already
-- parsed the null_exclusion part and has also removed the ACCESS token;
-- otherwise the caller has just checked that the initial token is ACCESS
-- Error recovery: can raise Error_Resync
function P_Access_Type_Definition return Node_Id is
Prot_Flag : Boolean;
Access_Loc : Source_Ptr;
Not_Null_Present : Boolean := False;
Type_Def_Node : Node_Id;
function P_Access_Type_Definition
(Header_Already_Parsed : Boolean := False) return Node_Id is
Access_Loc : constant Source_Ptr := Token_Ptr;
Prot_Flag : Boolean;
Not_Null_Present : Boolean := False;
Type_Def_Node : Node_Id;
procedure Check_Junk_Subprogram_Name;
-- Used in access to subprogram definition cases to check for an
@ -3266,13 +3326,11 @@ package body Ch3 is
-- Start of processing for P_Access_Type_Definition
begin
if Extensions_Allowed then -- Ada 0Y (AI-231)
Not_Null_Present := P_Null_Exclusion;
if not Header_Already_Parsed then
Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
Scan; -- past ACCESS
end if;
Access_Loc := Token_Ptr;
Scan; -- past ACCESS
if Token_Name = Name_Protected then
Check_95_Keyword (Tok_Protected, Tok_Procedure);
Check_95_Keyword (Tok_Protected, Tok_Function);
@ -3366,33 +3424,74 @@ package body Ch3 is
-- ACCESS_DEFINITION ::=
-- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
-- | ACCESS_TO_SUBPROGRAM_DEFINITION
--
-- ACCESS_TO_SUBPROGRAM_DEFINITION
-- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
-- | [NULL_EXCLUSION] access [protected] function
-- PARAMETER_AND_RESULT_PROFILE
-- The caller has checked that the initial token is ACCESS
-- The caller has parsed the null-exclusion part and it has also checked
-- that the next token is ACCESS
-- Error recovery: cannot raise Error_Resync
function P_Access_Definition return Node_Id is
Def_Node : Node_Id;
function P_Access_Definition
(Null_Exclusion_Present : Boolean) return Node_Id is
Def_Node : Node_Id;
Subp_Node : Node_Id;
begin
Def_Node := New_Node (N_Access_Definition, Token_Ptr);
Scan; -- past ACCESS
-- Ada 0Y (AI-231)
-- Ada 0Y (AI-254/AI-231)
if Extensions_Allowed then
if Token = Tok_All then
Scan; -- past ALL
Set_All_Present (Def_Node);
elsif Token = Tok_Constant then
Scan; -- past CONSTANT
Set_Constant_Present (Def_Node);
-- Ada 0Y (AI-254): Access_To_Subprogram_Definition
if Token = Tok_Protected
or else Token = Tok_Procedure
or else Token = Tok_Function
then
Subp_Node :=
P_Access_Type_Definition (Header_Already_Parsed => True);
Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present);
Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node);
-- Ada 0Y (AI-231)
-- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
else
Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present);
if Token = Tok_All then
Scan; -- past ALL
Set_All_Present (Def_Node);
elsif Token = Tok_Constant then
Scan; -- past CONSTANT
Set_Constant_Present (Def_Node);
end if;
Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
No_Constraint;
end if;
-- Ada 95
else
-- Ada 0Y (AI-254): The null-exclusion present is never present
-- in Ada 83 and Ada 95
pragma Assert (Null_Exclusion_Present = False);
Set_Null_Exclusion_Present (Def_Node, False);
Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
No_Constraint;
end if;
Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
No_Constraint;
return Def_Node;
end P_Access_Definition;

4
gcc/ada/par-ch6.adb
View file

@ -963,8 +963,8 @@ package body Ch6 is
Error_Msg_SC ("(Ada 83) access parameters not allowed");
end if;
Set_Parameter_Type
(Specification_Node, P_Access_Definition);
Set_Parameter_Type (Specification_Node,
P_Access_Definition (Not_Null_Present));
else
if Token = Tok_In or else Token = Tok_Out then

2
gcc/ada/par-prag.adb
View file

@ -655,7 +655,7 @@ begin
if Nast /= 1 then
Error_Msg_N
("file name pattern must have exactly one * character",
Arg2);
Arg1);
return Pragma_Node;
end if;

14
gcc/ada/par.adb
View file

@ -557,8 +557,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- variable, then the caller can change it to an appropriate missing
-- begin message if indeed the BEGIN is missing.
function P_Access_Definition return Node_Id;
function P_Access_Type_Definition return Node_Id;
function P_Array_Type_Definition return Node_Id;
function P_Basic_Declarative_Items return List_Id;
function P_Constraint_Opt return Node_Id;
@ -576,6 +574,17 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
function P_Subtype_Mark_Resync return Node_Id;
function P_Unknown_Discriminant_Part_Opt return Boolean;
function P_Access_Definition
(Null_Exclusion_Present : Boolean) return Node_Id;
-- Ada 0Y (AI-231/AI-254): The caller parses the null-exclusion part
-- and indicates if it was present
function P_Access_Type_Definition
(Header_Already_Parsed : Boolean := False) return Node_Id;
-- Ada 0Y (AI-254): The formal is used to indicate if the caller has
-- parsed the null_exclusion part. In this case the caller has also
-- removed the ACCESS token
procedure P_Component_Items (Decls : List_Id);
-- Scan out one or more component items and append them to the
-- given list. Only scans out more than one declaration in the
@ -1268,7 +1277,6 @@ begin
Save_Style_Check : constant Boolean := Style_Check;
begin
Operating_Mode := Check_Syntax;
Style_Check := False;

4
gcc/ada/prj-env.adb
View file

@ -572,7 +572,9 @@ package body Prj.Env is
-- For call to Close
procedure Check (Project : Project_Id);
-- ??? requires a comment
-- Recursive procedure that put in the config pragmas file any non
-- standard naming schemes, if it is not already in the file, then call
-- itself for any imported project.
procedure Check_Temp_File;
-- Check that a temporary file has been opened.

8
gcc/ada/prj-env.ads
View file

@ -24,16 +24,16 @@
-- --
------------------------------------------------------------------------------
-- This package implements services for Project-aware tools, related
-- to the environment (gnat.adc, ADA_INCLUDE_PATH, ADA_OBJECTS_PATH)
-- This package implements services for Project-aware tools, mostly related
-- to the environment (configuration pragma files, path files, mapping files).
with GNAT.OS_Lib; use GNAT.OS_Lib;
package Prj.Env is
procedure Initialize;
-- Put Standard_Naming_Data into Namings table (called by Prj.Initialize)
-- Above comment is obsolete (see body) ???
-- Called by Prj.Initialize to perform required initialization
-- steps for this package.
procedure Print_Sources;
-- Output the list of sources, after Project files have been scanned

2289
gcc/ada/prj-nmsc.adb
View file

File diff suppressed because it is too large Load diff

37
gcc/ada/prj-nmsc.ads
View file

@ -24,8 +24,7 @@
-- --
------------------------------------------------------------------------------
-- Check the Naming Scheme of a project file, find the directories
-- and the source files.
-- Check the Naming Scheme of a project file, find the source files.
private package Prj.Nmsc is
@ -33,16 +32,31 @@ private package Prj.Nmsc is
-- procedures do (related to their names), rather than just an english
-- language summary of the implementation ???
procedure Other_Languages_Check
(Project : Project_Id;
Report_Error : Put_Line_Access);
-- Call Language_Independent_Check
--
-- Check the naming scheme for the supported languages (c, c++, ...) other
-- than Ada. Find the source files if any.
--
-- If Report_Error is null, use the standard error reporting mechanism
-- (Errout). Otherwise, report errors using Report_Error.
procedure Ada_Check
(Project : Project_Id;
Report_Error : Put_Line_Access;
Trusted_Mode : Boolean);
-- Call Language_Independent_Check.
-- Check the naming scheme for Ada.
-- Find the Ada source files if any.
Follow_Links : Boolean);
-- Call Language_Independent_Check
--
-- Check the naming scheme for Ada
--
-- Find the Ada source files if any
--
-- If Report_Error is null , use the standard error reporting mechanism
-- (Errout). Otherwise, report errors using Report_Error.
-- If Trusted_Mode is True, it is assumed that the project doesn't contain
--
-- If Follow_Links is False, it is assumed that the project doesn't contain
-- any file duplicated through symbolic links (although the latter are
-- still valid if they point to a file which is outside of the project),
-- and that no directory has a name which is a valid source name.
@ -50,9 +64,12 @@ private package Prj.Nmsc is
procedure Language_Independent_Check
(Project : Project_Id;
Report_Error : Put_Line_Access);
-- Check the object directory and the source directories.
-- Check the library attributes, including the library directory if any.
-- Get the set of specification and implementation suffixes, if any.
-- Check the object directory and the source directories
--
-- Check the library attributes, including the library directory if any
--
-- Get the set of specification and implementation suffixes, if any
--
-- If Report_Error is null , use the standard error reporting mechanism
-- (Errout). Otherwise, report errors using Report_Error.

12
gcc/ada/prj-pars.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -26,9 +26,10 @@
with Ada.Exceptions; use Ada.Exceptions;
with Prj.Err; use Prj.Err;
with Opt;
with Output; use Output;
with Prj.Com; use Prj.Com;
with Prj.Err; use Prj.Err;
with Prj.Part;
with Prj.Proc;
with Prj.Tree; use Prj.Tree;
@ -42,7 +43,8 @@ package body Prj.Pars is
procedure Parse
(Project : out Project_Id;
Project_File_Name : String;
Packages_To_Check : String_List_Access := All_Packages)
Packages_To_Check : String_List_Access := All_Packages;
Process_Languages : Languages_Processed := Ada_Language)
is
Project_Tree : Project_Node_Id := Empty_Node;
The_Project : Project_Id := No_Project;
@ -64,7 +66,9 @@ package body Prj.Pars is
(Project => The_Project,
Success => Success,
From_Project_Node => Project_Tree,
Report_Error => null);
Report_Error => null,
Process_Languages => Process_Languages,
Follow_Links => Opt.Follow_Links);
Prj.Err.Finalize;
if not Success then

5
gcc/ada/prj-pars.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2000-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -36,7 +36,8 @@ package Prj.Pars is
procedure Parse
(Project : out Project_Id;
Project_File_Name : String;
Packages_To_Check : String_List_Access := All_Packages);
Packages_To_Check : String_List_Access := All_Packages;
Process_Languages : Languages_Processed := Ada_Language);
-- Parse a project files and all its imported project files.
-- If parsing is successful, Project_Id is the project ID
-- of the main project file; otherwise, Project_Id is set

45
gcc/ada/prj-proc.adb
View file

@ -101,16 +101,22 @@ package body Prj.Proc is
-- recursively for all imported projects and a extended project, if any.
-- Then process the declarative items of the project.
procedure Check (Project : in out Project_Id; Trusted_Mode : Boolean);
procedure Check
(Project : in out Project_Id;
Process_Languages : Languages_Processed;
Follow_Links : Boolean);
-- Set all projects to not checked, then call Recursive_Check for the
-- main project Project. Project is set to No_Project if errors occurred.
-- See Prj.Nmsc.Ada_Check for information on Trusted_Mode.
-- See Prj.Nmsc.Ada_Check for information on Follow_Links.
procedure Recursive_Check (Project : Project_Id; Trusted_Mode : Boolean);
procedure Recursive_Check
(Project : Project_Id;
Process_Languages : Languages_Processed;
Follow_Links : Boolean);
-- If Project is not marked as checked, mark it as checked, call
-- Check_Naming_Scheme for the project, then call itself for a
-- possible extended project and all the imported projects of Project.
-- See Prj.Nmsc.Ada_Check for information on Trusted_Mode
-- See Prj.Nmsc.Ada_Check for information on Follow_Links
---------
-- Add --
@ -207,7 +213,10 @@ package body Prj.Proc is
-- Check --
-----------
procedure Check (Project : in out Project_Id; Trusted_Mode : Boolean) is
procedure Check
(Project : in out Project_Id;
Process_Languages : Languages_Processed;
Follow_Links : Boolean) is
begin
-- Make sure that all projects are marked as not checked
@ -215,7 +224,8 @@ package body Prj.Proc is
Projects.Table (Index).Checked := False;
end loop;
Recursive_Check (Project, Trusted_Mode);
Recursive_Check (Project, Process_Languages, Follow_Links);
end Check;
----------------
@ -817,7 +827,8 @@ package body Prj.Proc is
Success : out Boolean;
From_Project_Node : Project_Node_Id;
Report_Error : Put_Line_Access;
Trusted_Mode : Boolean := False)
Process_Languages : Languages_Processed := Ada_Language;
Follow_Links : Boolean := True)
is
Obj_Dir : Name_Id;
Extending : Project_Id;
@ -841,7 +852,7 @@ package body Prj.Proc is
Extended_By => No_Project);
if Project /= No_Project then
Check (Project, Trusted_Mode);
Check (Project, Process_Languages, Follow_Links);
end if;
-- If main project is an extending all project, set the object
@ -1755,7 +1766,11 @@ package body Prj.Proc is
-- Recursive_Check --
---------------------
procedure Recursive_Check (Project : Project_Id; Trusted_Mode : Boolean) is
procedure Recursive_Check
(Project : Project_Id;
Process_Languages : Languages_Processed;
Follow_Links : Boolean)
is
Data : Project_Data;
Imported_Project_List : Project_List := Empty_Project_List;
@ -1776,7 +1791,7 @@ package body Prj.Proc is
-- Call itself for a possible extended project.
-- (if there is no extended project, then nothing happens).
Recursive_Check (Data.Extends, Trusted_Mode);
Recursive_Check (Data.Extends, Process_Languages, Follow_Links);
-- Call itself for all imported projects
@ -1784,7 +1799,7 @@ package body Prj.Proc is
while Imported_Project_List /= Empty_Project_List loop
Recursive_Check
(Project_Lists.Table (Imported_Project_List).Project,
Trusted_Mode);
Process_Languages, Follow_Links);
Imported_Project_List :=
Project_Lists.Table (Imported_Project_List).Next;
end loop;
@ -1795,7 +1810,13 @@ package body Prj.Proc is
Write_Line ("""");
end if;
Prj.Nmsc.Ada_Check (Project, Error_Report, Trusted_Mode);
case Process_Languages is
when Ada_Language =>
Prj.Nmsc.Ada_Check (Project, Error_Report, Follow_Links);
when Other_Languages =>
Prj.Nmsc.Other_Languages_Check (Project, Error_Report);
end case;
end if;
end Recursive_Check;

6
gcc/ada/prj-proc.ads
View file

@ -37,15 +37,17 @@ package Prj.Proc is
Success : out Boolean;
From_Project_Node : Project_Node_Id;
Report_Error : Put_Line_Access;
Trusted_Mode : Boolean := False);
Process_Languages : Languages_Processed := Ada_Language;
Follow_Links : Boolean := True);
-- Process a project file tree into project file data structures.
-- If Report_Error is null, use the error reporting mechanism.
-- Otherwise, report errors using Report_Error.
--
-- If Trusted_Mode is True, it is assumed that the project doesn't contain
-- If Follow_Links is False, it is assumed that the project doesn't contain
-- any file duplicated through symbolic links (although the latter are
-- still valid if they point to a file which is outside of the project),
-- and that no directory has a name which is a valid source name.
--
-- Process is a bit of a junk name, how about Process_Project_Tree???
end Prj.Proc;

36
gcc/ada/prj-util.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -74,7 +74,9 @@ package body Prj.Util is
-------------------
function Executable_Of
(Project : Project_Id; Main : Name_Id) return Name_Id
(Project : Project_Id;
Main : Name_Id;
Ada_Main : Boolean := True) return Name_Id
is
pragma Assert (Project /= No_Project);
@ -111,7 +113,7 @@ package body Prj.Util is
begin
if Builder_Package /= No_Package then
if Executable = Nil_Variable_Value then
if Executable = Nil_Variable_Value and Ada_Main then
Get_Name_String (Main);
-- Try as index the name minus the implementation suffix or minus
@ -212,7 +214,7 @@ package body Prj.Util is
-- otherwise remove any suffix ('.' followed by other characters), if
-- there is one.
if Name_Len > Body_Append'Length
if Ada_Main and then Name_Len > Body_Append'Length
and then Name_Buffer (Name_Len - Body_Append'Length + 1 .. Name_Len) =
Body_Append
then
@ -220,7 +222,7 @@ package body Prj.Util is
Name_Len := Name_Len - Body_Append'Length;
elsif Name_Len > Spec_Append'Length
elsif Ada_Main and then Name_Len > Spec_Append'Length
and then Name_Buffer (Name_Len - Spec_Append'Length + 1 .. Name_Len) =
Spec_Append
then
@ -379,8 +381,7 @@ package body Prj.Util is
function Value_Of
(Variable : Variable_Value;
Default : String)
return String
Default : String) return String
is
begin
if Variable.Kind /= Single
@ -395,8 +396,7 @@ package body Prj.Util is
function Value_Of
(Index : Name_Id;
In_Array : Array_Element_Id)
return Name_Id
In_Array : Array_Element_Id) return Name_Id
is
Current : Array_Element_Id := In_Array;
Element : Array_Element;
@ -432,8 +432,7 @@ package body Prj.Util is
function Value_Of
(Index : Name_Id;
In_Array : Array_Element_Id)
return Variable_Value
In_Array : Array_Element_Id) return Variable_Value
is
Current : Array_Element_Id := In_Array;
Element : Array_Element;
@ -468,8 +467,7 @@ package body Prj.Util is
function Value_Of
(Name : Name_Id;
Attribute_Or_Array_Name : Name_Id;
In_Package : Package_Id)
return Variable_Value
In_Package : Package_Id) return Variable_Value
is
The_Array : Array_Element_Id;
The_Attribute : Variable_Value := Nil_Variable_Value;
@ -504,8 +502,7 @@ package body Prj.Util is
function Value_Of
(Index : Name_Id;
In_Array : Name_Id;
In_Arrays : Array_Id)
return Name_Id
In_Arrays : Array_Id) return Name_Id
is
Current : Array_Id := In_Arrays;
The_Array : Array_Data;
@ -525,8 +522,7 @@ package body Prj.Util is
function Value_Of
(Name : Name_Id;
In_Arrays : Array_Id)
return Array_Element_Id
In_Arrays : Array_Id) return Array_Element_Id
is
Current : Array_Id := In_Arrays;
The_Array : Array_Data;
@ -547,8 +543,7 @@ package body Prj.Util is
function Value_Of
(Name : Name_Id;
In_Packages : Package_Id)
return Package_Id
In_Packages : Package_Id) return Package_Id
is
Current : Package_Id := In_Packages;
The_Package : Package_Element;
@ -566,8 +561,7 @@ package body Prj.Util is
function Value_Of
(Variable_Name : Name_Id;
In_Variables : Variable_Id)
return Variable_Value
In_Variables : Variable_Id) return Variable_Value
is
Current : Variable_Id := In_Variables;
The_Variable : Variable;

30
gcc/ada/prj-util.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -33,7 +33,9 @@ with GNAT.OS_Lib; use GNAT.OS_Lib;
package Prj.Util is
function Executable_Of
(Project : Project_Id; Main : Name_Id) return Name_Id;
(Project : Project_Id;
Main : Name_Id;
Ada_Main : Boolean := True) return Name_Id;
-- Return the value of the attribute Builder'Executable for file Main in
-- the project Project, if it exists. If there is no attribute Executable
-- for Main, remove the suffix from Main; then, if the attribute
@ -42,15 +44,13 @@ package Prj.Util is
function Value_Of
(Variable : Variable_Value;
Default : String)
return String;
Default : String) return String;
-- Get the value of a single string variable. If Variable is
-- Nil_Variable_Value, is a string list or is defaulted, return Default.
function Value_Of
(Index : Name_Id;
In_Array : Array_Element_Id)
return Name_Id;
In_Array : Array_Element_Id) return Name_Id;
-- Get a single string array component. Returns No_Name if there is no
-- component Index, if In_Array is null, or if the component is a String
-- list. Depending on the attribute (only attributes may be associative
@ -60,8 +60,7 @@ package Prj.Util is
function Value_Of
(Index : Name_Id;
In_Array : Array_Element_Id)
return Variable_Value;
In_Array : Array_Element_Id) return Variable_Value;
-- Get a string array component (single String or String list).
-- Returns Nil_Variable_Value if there is no component Index
-- or if In_Array is null.
@ -74,8 +73,7 @@ package Prj.Util is
function Value_Of
(Name : Name_Id;
Attribute_Or_Array_Name : Name_Id;
In_Package : Package_Id)
return Variable_Value;
In_Package : Package_Id) return Variable_Value;
-- In a specific package,
-- - if there exists an array Attribute_Or_Array_Name with an index
-- Name, returns the corresponding component (depending on the
@ -89,32 +87,28 @@ package Prj.Util is
function Value_Of
(Index : Name_Id;
In_Array : Name_Id;
In_Arrays : Array_Id)
return Name_Id;
In_Arrays : Array_Id) return Name_Id;
-- Get a string array component in an array of an array list.
-- Returns No_Name if there is no component Index, if In_Arrays is null, if
-- In_Array is not found in In_Arrays or if the component is a String list.
function Value_Of
(Name : Name_Id;
In_Arrays : Array_Id)
return Array_Element_Id;
In_Arrays : Array_Id) return Array_Element_Id;
-- Returns a specified array in an array list. Returns No_Array_Element
-- if In_Arrays is null or if Name is not the name of an array in
-- In_Arrays. The caller must ensure that Name is in lower case.
function Value_Of
(Name : Name_Id;
In_Packages : Package_Id)
return Package_Id;
In_Packages : Package_Id) return Package_Id;
-- Returns a specified package in a package list. Returns No_Package
-- if In_Packages is null or if Name is not the name of a package in
-- Package_List. The caller must ensure that Name is in lower case.
function Value_Of
(Variable_Name : Name_Id;
In_Variables : Variable_Id)
return Variable_Value;
In_Variables : Variable_Id) return Variable_Value;
-- Returns a specified variable in a variable list. Returns null if
-- In_Variables is null or if Variable_Name is not the name of a
-- variable in In_Variables. Caller must ensure that Name is lower case.

23
gcc/ada/prj.adb
View file

@ -41,8 +41,6 @@ package body Prj is
The_Empty_String : Name_Id;
Ada_Language : constant Name_Id := Name_Ada;
subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
The_Casing_Images : constant array (Known_Casing) of String_Access :=
@ -74,7 +72,9 @@ package body Prj is
Implementation_Exceptions => No_Array_Element);
Project_Empty : constant Project_Data :=
(First_Referred_By => No_Project,
(Languages => No_Languages,
Impl_Suffixes => No_Impl_Suffixes,
First_Referred_By => No_Project,
Name => No_Name,
Path_Name => No_Name,
Virtual => False,
@ -99,6 +99,11 @@ package body Prj is
Symbol_Data => No_Symbols,
Sources_Present => True,
Sources => Nil_String,
First_Other_Source => No_Other_Source,
Last_Other_Source => No_Other_Source,
Imported_Directories_Switches => null,
Include_Path => null,
Include_Data_Set => False,
Source_Dirs => Nil_String,
Known_Order_Of_Source_Dirs => True,
Object_Directory => No_Name,
@ -247,11 +252,21 @@ package body Prj is
Name_Len := 1;
Name_Buffer (1) := '/';
Slash := Name_Find;
for Lang in Programming_Language loop
Name_Len := Lang_Names (Lang)'Length;
Name_Buffer (1 .. Name_Len) := Lang_Names (Lang).all;
Lang_Name_Ids (Lang) := Name_Find;
Name_Len := Lang_Suffixes (Lang)'Length;
Name_Buffer (1 .. Name_Len) := Lang_Suffixes (Lang).all;
Lang_Suffix_Ids (Lang) := Name_Find;
end loop;
Std_Naming_Data.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
Std_Naming_Data.Current_Body_Suffix := Default_Ada_Body_Suffix;
Std_Naming_Data.Separate_Suffix := Default_Ada_Body_Suffix;
Register_Default_Naming_Scheme
(Language => Ada_Language,
(Language => Name_Ada,
Default_Spec_Suffix => Default_Ada_Spec_Suffix,
Default_Body_Suffix => Default_Ada_Body_Suffix);
Prj.Env.Initialize;

121
gcc/ada/prj.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -67,6 +67,103 @@ package Prj is
Slash : Name_Id;
-- "/", used as the path of locally removed files
type Languages_Processed is (Ada_Language, Other_Languages);
-- To specify how to process project files
type Programming_Language is
(Lang_Ada, Lang_C, Lang_C_Plus_Plus, Lang_Fortran);
-- The list of language supported
subtype Other_Programming_Language is
Programming_Language range Lang_C .. Programming_Language'Last;
type Languages_In_Project is array (Programming_Language) of Boolean;
No_Languages : constant Languages_In_Project := (others => False);
type Impl_Suffix_Array is array (Programming_Language) of Name_Id;
No_Impl_Suffixes : constant Impl_Suffix_Array := (others => No_Name);
Lang_Ada_Name : aliased String := "ada";
Lang_C_Name : aliased String := "c";
Lang_C_Plus_Plus_Name : aliased String := "c++";
Lang_Fortran_Name : aliased String := "for";
Lang_Names : constant array (Programming_Language) of String_Access :=
(Lang_Ada => Lang_Ada_Name 'Access,
Lang_C => Lang_C_Name 'Access,
Lang_C_Plus_Plus => Lang_C_Plus_Plus_Name'Access,
Lang_Fortran => Lang_Fortran_Name'Access);
-- Names of the supported programming languages, to be used after switch
-- -x when using a GCC compiler.
Lang_Name_Ids : array (Programming_Language) of Name_Id;
-- Initialized by Prj.Initialize
Lang_Ada_Display_Name : aliased String := "Ada";
Lang_C_Display_Name : aliased String := "C";
Lang_C_Plus_Plus_Display_Name : aliased String := "C++";
Lang_Fortran_Display_Name : aliased String := "Fortran";
Lang_Display_Names :
constant array (Programming_Language) of String_Access :=
(Lang_Ada => Lang_Ada_Display_Name 'Access,
Lang_C => Lang_C_Display_Name 'Access,
Lang_C_Plus_Plus => Lang_C_Plus_Plus_Display_Name'Access,
Lang_Fortran => Lang_Fortran_Display_Name'Access);
-- Names of the supported programming languages, to be used for display
-- purposes.
Ada_Impl_Suffix : aliased String := ".adb";
C_Impl_Suffix : aliased String := ".c";
C_Plus_Plus_Impl_Suffix : aliased String := ".cc";
Fortran_Impl_Suffix : aliased String := ".for";
Lang_Suffixes : constant array (Programming_Language) of String_Access :=
(Lang_Ada => Ada_Impl_Suffix 'Access,
Lang_C => C_Impl_Suffix 'Access,
Lang_C_Plus_Plus => C_Plus_Plus_Impl_Suffix'Access,
Lang_Fortran => Fortran_Impl_Suffix'Access);
-- Default extension of the sources of the different languages.
Lang_Suffix_Ids : array (Programming_Language) of Name_Id;
-- Initialized by Prj.Initialize
Gnatmake_String : aliased String := "gnatmake";
Gcc_String : aliased String := "gcc";
G_Plus_Plus_String : aliased String := "g++";
G77_String : aliased String := "g77";
Default_Compiler_Names :
constant array (Programming_Language) of String_Access :=
(Lang_Ada => Gnatmake_String 'Access,
Lang_C => Gcc_String 'Access,
Lang_C_Plus_Plus => G_Plus_Plus_String'Access,
Lang_Fortran => G77_String 'Access);
-- Default names of the compilers for the supported languages.
-- Used when no IDE'Compiler_Command is specified for a language.
-- For Ada, specify the gnatmake executable.
type Other_Source_Id is new Nat;
No_Other_Source : constant Other_Source_Id := 0;
type Other_Source is record
Language : Programming_Language; -- language of the source
File_Name : Name_Id; -- source file simple name
Path_Name : Name_Id; -- source full path name
Source_TS : Time_Stamp_Type; -- source file time stamp
Object_Name : Name_Id; -- object file simple name
Object_Path : Name_Id; -- object full path name
Object_TS : Time_Stamp_Type; -- object file time stamp
Dep_Name : Name_Id; -- dependency file simple name
Dep_Path : Name_Id; -- dependency full path name
Dep_TS : Time_Stamp_Type; -- dependency file time stamp
Naming_Exception : Boolean := False; -- True if a naming exception
Next : Other_Source_Id := No_Other_Source;
end record;
package Other_Sources is new Table.Table
(Table_Component_Type => Other_Source,
Table_Index_Type => Other_Source_Id,
Table_Low_Bound => 1,
Table_Initial => 200,
Table_Increment => 100,
Table_Name => "Prj.Other_Sources");
-- The table for sources of languages other than Ada
type Verbosity is (Default, Medium, High);
-- Verbosity when parsing GNAT Project Files
-- Default is default (very quiet, if no errors).
@ -347,6 +444,12 @@ package Prj is
-- The following record describes a project file representation
type Project_Data is record
Languages : Languages_In_Project := No_Languages;
-- Indicate the different languages of the source of this project
Impl_Suffixes : Impl_Suffix_Array := No_Impl_Suffixes;
-- The source suffixes of the different languages other than Ada
First_Referred_By : Project_Id := No_Project;
-- The project, if any, that was the first to be known
-- as importing or extending this project.
@ -447,6 +550,22 @@ package Prj is
-- The list of all the source file names.
-- Set by Prj.Nmsc.Check_Naming_Scheme.
First_Other_Source : Other_Source_Id := No_Other_Source;
Last_Other_Source : Other_Source_Id := No_Other_Source;
-- Head and tail of the list of sources of languages other than Ada
Imported_Directories_Switches : Argument_List_Access := null;
-- List of the -I switches to be used when compiling sources of
-- languages other than Ada.
Include_Path : String_Access := null;
-- Value to be used as CPATH, when using a GCC, instead of a list of
-- -I switches.
Include_Data_Set : Boolean := False;
-- Set to True when Imported_Directories_Switches or Include_Path are
-- set.
Source_Dirs : String_List_Id := Nil_String;
-- The list of all the source directories.
-- Set by Prj.Nmsc.Check_Naming_Scheme.

261
gcc/ada/rtsfind.ads
View file

@ -279,6 +279,7 @@ package Rtsfind is
System_Pack_63,
System_Parameters,
System_Partition_Interface,
System_PolyORB_Interface,
System_Pool_Global,
System_Pool_Empty,
System_Pool_Local,
@ -1003,7 +1004,6 @@ package Rtsfind is
RE_Get_Unique_Remote_Pointer, -- System.Partition_Interface
RE_RACW_Stub_Type, -- System.Partition_Interface
RE_RACW_Stub_Type_Access, -- System.Partition_Interface
RE_Raise_Program_Error_For_E_4_18, -- System.Partition_Interface
RE_Raise_Program_Error_Unknown_Tag, -- System.Partition_Interface
RE_Register_Passive_Package, -- System.Partition_Interface
RE_Register_Receiving_Stub, -- System.Partition_Interface
@ -1022,6 +1022,135 @@ package Rtsfind is
RE_Partition_ID, -- System.RPC
RE_RPC_Receiver, -- System.RPC
RE_To_PolyORB_String, -- System.PolyORB_Interface
RE_To_Standard_String, -- System.PolyORB_Interface
RE_Caseless_String_Eq, -- System.PolyORB_Interface
RE_TypeCode, -- System.PolyORB_Interface
RE_Any, -- System.PolyORB_Interface
RE_Mode_In, -- System.PolyORB_Interface
RE_Mode_Out, -- System.PolyORB_Interface
RE_Mode_Inout, -- System.PolyORB_Interface
RE_NamedValue, -- System.PolyORB_Interface
RE_Result_Name, -- System.PolyORB_Interface
RE_Object_Ref, -- System.PolyORB_Interface
RE_Create_Any, -- System.PolyORB_Interface
RE_Any_Aggregate_Build, -- System.PolyORB_Interface
RE_Add_Aggregate_Element, -- System.PolyORB_Interface
RE_Get_Aggregate_Element, -- System.PolyORB_Interface
RE_Content_Type, -- System.PolyORB_Interface
RE_Any_Member_Type, -- System.PolyORB_Interface
RE_Get_Nested_Sequence_Length, -- System.PolyORB_Interface
RE_Extract_Union_Value, -- System.PolyORB_Interface
RE_NVList_Ref, -- System.PolyORB_Interface
RE_NVList_Create, -- System.PolyORB_Interface
RE_NVList_Add_Item, -- System.PolyORB_Interface
RE_Request_Access, -- System.PolyORB_Interface
RE_Request_Create, -- System.PolyORB_Interface
RE_Request_Invoke, -- System.PolyORB_Interface
RE_Request_Arguments, -- System.PolyORB_Interface
RE_Request_Set_Out, -- System.PolyORB_Interface
RE_Request_Raise_Occurrence, -- System.PolyORB_Interface
RE_Nil_Exc_List, -- System.PolyORB_Interface
RE_Servant, -- System.PolyORB_Interface
RE_Copy_Any_Value, -- System.PolyORB_Interface
RE_Set_Result, -- System.PolyORB_Interface
RE_Register_Obj_Receiving_Stub, -- System.PolyORB_Interface
RE_Register_Pkg_Receiving_Stub, -- System.PolyORB_Interface
RE_Is_Nil, -- System.PolyORB_Interface
RE_Entity_Ptr, -- System.PolyORB_Interface
RE_Entity_Of, -- System.PolyORB_Interface
RE_Inc_Usage, -- System.PolyORB_Interface
RE_Set_Ref, -- System.PolyORB_Interface
RE_Get_Local_Address, -- System.PolyORB_Interface
RE_Get_Reference, -- System.PolyORB_Interface
RE_Local_Oid_To_Address, -- System.PolyORB_Interface
RE_RCI_Locator, -- System.PolyORB_Interface
RE_RCI_Subp_Info, -- System.PolyORB_Interface
RE_RCI_Subp_Info_Array, -- System.PolyORB_Interface
RE_Get_RAS_Ref, -- System.PolyORB_Interface
RE_Asynchronous_P_To_Sync_Scope, -- System.PolyORB_Interface
RE_Buffer_Stream_Type, -- System.PolyORB_Interface
RE_Allocate_Buffer, -- System.PolyORB_Interface
RE_Release_Buffer, -- System.PolyORB_Interface
RE_BS_To_Any, -- System.PolyORB_Interface
RE_Any_To_BS, -- System.PolyORB_Interface
RE_FA_AD, -- System.PolyORB_Interface
RE_FA_AS, -- System.PolyORB_Interface
RE_FA_B, -- System.PolyORB_Interface
RE_FA_C, -- System.PolyORB_Interface
RE_FA_F, -- System.PolyORB_Interface
RE_FA_I, -- System.PolyORB_Interface
RE_FA_LF, -- System.PolyORB_Interface
RE_FA_LI, -- System.PolyORB_Interface
RE_FA_LLF, -- System.PolyORB_Interface
RE_FA_LLI, -- System.PolyORB_Interface
RE_FA_LLU, -- System.PolyORB_Interface
RE_FA_LU, -- System.PolyORB_Interface
RE_FA_SF, -- System.PolyORB_Interface
RE_FA_SI, -- System.PolyORB_Interface
RE_FA_SSI, -- System.PolyORB_Interface
RE_FA_SSU, -- System.PolyORB_Interface
RE_FA_SU, -- System.PolyORB_Interface
RE_FA_U, -- System.PolyORB_Interface
RE_FA_WC, -- System.PolyORB_Interface
RE_FA_String, -- System.PolyORB_Interface
RE_FA_ObjRef, -- System.PolyORB_Interface
RE_TA_AD, -- System.PolyORB_Interface
RE_TA_AS, -- System.PolyORB_Interface
RE_TA_B, -- System.PolyORB_Interface
RE_TA_C, -- System.PolyORB_Interface
RE_TA_F, -- System.PolyORB_Interface
RE_TA_I, -- System.PolyORB_Interface
RE_TA_LF, -- System.PolyORB_Interface
RE_TA_LI, -- System.PolyORB_Interface
RE_TA_LLF, -- System.PolyORB_Interface
RE_TA_LLI, -- System.PolyORB_Interface
RE_TA_LLU, -- System.PolyORB_Interface
RE_TA_LU, -- System.PolyORB_Interface
RE_TA_SF, -- System.PolyORB_Interface
RE_TA_SI, -- System.PolyORB_Interface
RE_TA_SSI, -- System.PolyORB_Interface
RE_TA_SSU, -- System.PolyORB_Interface
RE_TA_SU, -- System.PolyORB_Interface
RE_TA_U, -- System.PolyORB_Interface
RE_TA_WC, -- System.PolyORB_Interface
RE_TA_String, -- System.PolyORB_Interface
RE_TA_ObjRef, -- System.PolyORB_Interface
RE_TA_TC, -- System.PolyORB_Interface
RE_TC_Alias, -- System.PolyORB_Interface
RE_TC_Build, -- System.PolyORB_Interface
RE_Set_TC, -- System.PolyORB_Interface
RE_TC_Any, -- System.PolyORB_Interface
RE_TC_AD, -- System.PolyORB_Interface
RE_TC_AS, -- System.PolyORB_Interface
RE_TC_B, -- System.PolyORB_Interface
RE_TC_C, -- System.PolyORB_Interface
RE_TC_F, -- System.PolyORB_Interface
RE_TC_I, -- System.PolyORB_Interface
RE_TC_LF, -- System.PolyORB_Interface
RE_TC_LI, -- System.PolyORB_Interface
RE_TC_LLF, -- System.PolyORB_Interface
RE_TC_LLI, -- System.PolyORB_Interface
RE_TC_LLU, -- System.PolyORB_Interface
RE_TC_LU, -- System.PolyORB_Interface
RE_TC_SF, -- System.PolyORB_Interface
RE_TC_SI, -- System.PolyORB_Interface
RE_TC_SSI, -- System.PolyORB_Interface
RE_TC_SSU, -- System.PolyORB_Interface
RE_TC_SU, -- System.PolyORB_Interface
RE_TC_U, -- System.PolyORB_Interface
RE_TC_Void, -- System.PolyORB_Interface
RE_TC_Opaque, -- System.PolyORB_Interface,
RE_TC_WC, -- System.PolyORB_Interface
RE_TC_Array, -- System.PolyORB_Interface,
RE_TC_Sequence, -- System.PolyORB_Interface,
RE_TC_String, -- System.PolyORB_Interface,
RE_TC_Struct, -- System.PolyORB_Interface,
RE_TC_Union, -- System.PolyORB_Interface,
RE_IS_Is1, -- System.Scalar_Values
RE_IS_Is2, -- System.Scalar_Values
RE_IS_Is4, -- System.Scalar_Values
@ -1944,13 +2073,141 @@ package Rtsfind is
RE_Get_Unique_Remote_Pointer => System_Partition_Interface,
RE_RACW_Stub_Type => System_Partition_Interface,
RE_RACW_Stub_Type_Access => System_Partition_Interface,
RE_Raise_Program_Error_For_E_4_18 => System_Partition_Interface,
RE_Raise_Program_Error_Unknown_Tag => System_Partition_Interface,
RE_Register_Passive_Package => System_Partition_Interface,
RE_Register_Receiving_Stub => System_Partition_Interface,
RE_RCI_Info => System_Partition_Interface,
RE_Subprogram_Id => System_Partition_Interface,
RE_To_PolyORB_String => System_PolyORB_Interface,
RE_To_Standard_String => System_PolyORB_Interface,
RE_Caseless_String_Eq => System_PolyORB_Interface,
RE_TypeCode => System_PolyORB_Interface,
RE_Any => System_PolyORB_Interface,
RE_Mode_In => System_PolyORB_Interface,
RE_Mode_Out => System_PolyORB_Interface,
RE_Mode_Inout => System_PolyORB_Interface,
RE_NamedValue => System_PolyORB_Interface,
RE_Result_Name => System_PolyORB_Interface,
RE_Object_Ref => System_PolyORB_Interface,
RE_Create_Any => System_PolyORB_Interface,
RE_Any_Aggregate_Build => System_PolyORB_Interface,
RE_Add_Aggregate_Element => System_PolyORB_Interface,
RE_Get_Aggregate_Element => System_PolyORB_Interface,
RE_Content_Type => System_PolyORB_Interface,
RE_Any_Member_Type => System_PolyORB_Interface,
RE_Get_Nested_Sequence_Length => System_PolyORB_Interface,
RE_Extract_Union_Value => System_PolyORB_Interface,
RE_NVList_Ref => System_PolyORB_Interface,
RE_NVList_Create => System_PolyORB_Interface,
RE_NVList_Add_Item => System_PolyORB_Interface,
RE_Request_Access => System_PolyORB_Interface,
RE_Request_Create => System_PolyORB_Interface,
RE_Request_Invoke => System_PolyORB_Interface,
RE_Request_Arguments => System_PolyORB_Interface,
RE_Request_Set_Out => System_PolyORB_Interface,
RE_Request_Raise_Occurrence => System_PolyORB_Interface,
RE_Nil_Exc_List => System_PolyORB_Interface,
RE_Servant => System_PolyORB_Interface,
RE_Copy_Any_Value => System_PolyORB_Interface,
RE_Set_Result => System_PolyORB_Interface,
RE_Register_Obj_Receiving_Stub => System_PolyORB_Interface,
RE_Register_Pkg_Receiving_Stub => System_PolyORB_Interface,
RE_Is_Nil => System_PolyORB_Interface,
RE_Entity_Ptr => System_PolyORB_Interface,
RE_Entity_Of => System_PolyORB_Interface,
RE_Inc_Usage => System_PolyORB_Interface,
RE_Set_Ref => System_PolyORB_Interface,
RE_Get_Local_Address => System_PolyORB_Interface,
RE_Get_Reference => System_PolyORB_Interface,
RE_Local_Oid_To_Address => System_PolyORB_Interface,
RE_RCI_Locator => System_PolyORB_Interface,
RE_RCI_Subp_Info => System_PolyORB_Interface,
RE_RCI_Subp_Info_Array => System_PolyORB_Interface,
RE_Get_RAS_Ref => System_PolyORB_Interface,
RE_Asynchronous_P_To_Sync_Scope => System_PolyORB_Interface,
RE_Buffer_Stream_Type => System_PolyORB_Interface,
RE_Allocate_Buffer => System_PolyORB_Interface,
RE_Release_Buffer => System_PolyORB_Interface,
RE_BS_To_Any => System_PolyORB_Interface,
RE_Any_To_BS => System_PolyORB_Interface,
RE_FA_AD => System_PolyORB_Interface,
RE_FA_AS => System_PolyORB_Interface,
RE_FA_B => System_PolyORB_Interface,
RE_FA_C => System_PolyORB_Interface,
RE_FA_F => System_PolyORB_Interface,
RE_FA_I => System_PolyORB_Interface,
RE_FA_LF => System_PolyORB_Interface,
RE_FA_LI => System_PolyORB_Interface,
RE_FA_LLF => System_PolyORB_Interface,
RE_FA_LLI => System_PolyORB_Interface,
RE_FA_LLU => System_PolyORB_Interface,
RE_FA_LU => System_PolyORB_Interface,
RE_FA_SF => System_PolyORB_Interface,
RE_FA_SI => System_PolyORB_Interface,
RE_FA_SSI => System_PolyORB_Interface,
RE_FA_SSU => System_PolyORB_Interface,
RE_FA_SU => System_PolyORB_Interface,
RE_FA_U => System_PolyORB_Interface,
RE_FA_WC => System_PolyORB_Interface,
RE_FA_String => System_PolyORB_Interface,
RE_FA_ObjRef => System_PolyORB_Interface,
RE_TA_AD => System_PolyORB_Interface,
RE_TA_AS => System_PolyORB_Interface,
RE_TA_B => System_PolyORB_Interface,
RE_TA_C => System_PolyORB_Interface,
RE_TA_F => System_PolyORB_Interface,
RE_TA_I => System_PolyORB_Interface,
RE_TA_LF => System_PolyORB_Interface,
RE_TA_LI => System_PolyORB_Interface,
RE_TA_LLF => System_PolyORB_Interface,
RE_TA_LLI => System_PolyORB_Interface,
RE_TA_LLU => System_PolyORB_Interface,
RE_TA_LU => System_PolyORB_Interface,
RE_TA_SF => System_PolyORB_Interface,
RE_TA_SI => System_PolyORB_Interface,
RE_TA_SSI => System_PolyORB_Interface,
RE_TA_SSU => System_PolyORB_Interface,
RE_TA_SU => System_PolyORB_Interface,
RE_TA_U => System_PolyORB_Interface,
RE_TA_WC => System_PolyORB_Interface,
RE_TA_String => System_PolyORB_Interface,
RE_TA_ObjRef => System_PolyORB_Interface,
RE_TA_TC => System_PolyORB_Interface,
RE_TC_Alias => System_PolyORB_Interface,
RE_TC_Build => System_PolyORB_Interface,
RE_Set_TC => System_PolyORB_Interface,
RE_TC_Any => System_PolyORB_Interface,
RE_TC_AD => System_PolyORB_Interface,
RE_TC_AS => System_PolyORB_Interface,
RE_TC_B => System_PolyORB_Interface,
RE_TC_C => System_PolyORB_Interface,
RE_TC_F => System_PolyORB_Interface,
RE_TC_I => System_PolyORB_Interface,
RE_TC_LF => System_PolyORB_Interface,
RE_TC_LI => System_PolyORB_Interface,
RE_TC_LLF => System_PolyORB_Interface,
RE_TC_LLI => System_PolyORB_Interface,
RE_TC_LLU => System_PolyORB_Interface,
RE_TC_LU => System_PolyORB_Interface,
RE_TC_SF => System_PolyORB_Interface,
RE_TC_SI => System_PolyORB_Interface,
RE_TC_SSI => System_PolyORB_Interface,
RE_TC_SSU => System_PolyORB_Interface,
RE_TC_SU => System_PolyORB_Interface,
RE_TC_U => System_PolyORB_Interface,
RE_TC_Void => System_PolyORB_Interface,
RE_TC_Opaque => System_PolyORB_Interface,
RE_TC_WC => System_PolyORB_Interface,
RE_TC_Array => System_PolyORB_Interface,
RE_TC_Sequence => System_PolyORB_Interface,
RE_TC_String => System_PolyORB_Interface,
RE_TC_Struct => System_PolyORB_Interface,
RE_TC_Union => System_PolyORB_Interface,
RE_Global_Pool_Object => System_Pool_Global,
RE_Unbounded_Reclaim_Pool => System_Pool_Local,

7
gcc/ada/s-auxdec.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/Or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -102,9 +102,8 @@ package body System.Aux_DEC is
function "-" (Left : Address; Right : Address) return Integer is
pragma Unsuppress (All_Checks);
-- Because this can raise Constraint_Error for 64-bit addresses
begin
return Integer (From_A (Left - Right));
return Integer (From_A (Left) - From_A (Right));
end "-";
function "-" (Left : Address; Right : Integer) return Address is
@ -120,7 +119,6 @@ package body System.Aux_DEC is
type T_Ptr is access all Target;
function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr);
Ptr : constant T_Ptr := To_T_Ptr (A);
begin
return Ptr.all;
end Fetch_From_Address;
@ -133,7 +131,6 @@ package body System.Aux_DEC is
type T_Ptr is access all Target;
function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr);
Ptr : constant T_Ptr := To_T_Ptr (A);
begin
Ptr.all := T;
end Assign_To_Address;

8
gcc/ada/s-carsi8.adb
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -35,6 +35,12 @@ with Unchecked_Conversion;
package body System.Compare_Array_Signed_8 is
function "+" (Left, Right : Address) return Address;
pragma Import (Intrinsic, "+");
-- Provide addition operation on type Address (this may not be directly
-- available if type System.Address is non-private and the operations on
-- the type are made abstract to hide them from public users of System.
type Word is mod 2 ** 32;
-- Used to process operands by words

8
gcc/ada/s-carsi8.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -44,8 +44,7 @@ package System.Compare_Array_Signed_8 is
(Left : System.Address;
Right : System.Address;
Left_Len : Natural;
Right_Len : Natural)
return Integer;
Right_Len : Natural) return Integer;
-- Compare the array starting at address Left of length Left_Len
-- with the array starting at address Right of length Right_Len.
-- The comparison is in the normal Ada semantic sense of array
@ -57,8 +56,7 @@ package System.Compare_Array_Signed_8 is
(Left : System.Address;
Right : System.Address;
Left_Len : Natural;
Right_Len : Natural)
return Integer;
Right_Len : Natural) return Integer;
-- Same functionality as Compare_Array_U8 but always proceeds by
-- bytes. Used when the caller knows that the operands are unaligned,
-- or short enough that it makes no sense to go by words.

8
gcc/ada/s-carun8.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -35,6 +35,12 @@ with Unchecked_Conversion;
package body System.Compare_Array_Unsigned_8 is
function "+" (Left, Right : Address) return Address;
pragma Import (Intrinsic, "+");
-- Provide addition operation on type Address (this may not be directly
-- available if type System.Address is non-private and the operations on
-- the type are made abstract to hide them from public users of System.
type Word is mod 2 ** 32;
-- Used to process operands by words

8
gcc/ada/s-carun8.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -44,8 +44,7 @@ package System.Compare_Array_Unsigned_8 is
(Left : System.Address;
Right : System.Address;
Left_Len : Natural;
Right_Len : Natural)
return Integer;
Right_Len : Natural) return Integer;
-- Compare the array starting at address Left of length Left_Len
-- with the array starting at address Right of length Right_Len.
-- The comparison is in the normal Ada semantic sense of array
@ -57,8 +56,7 @@ package System.Compare_Array_Unsigned_8 is
(Left : System.Address;
Right : System.Address;
Left_Len : Natural;
Right_Len : Natural)
return Integer;
Right_Len : Natural) return Integer;
-- Same functionality as Compare_Array_U8 but always proceeds by
-- bytes. Used when the caller knows that the operands are unaligned,
-- or short enough that it makes no sense to go by words.

8
gcc/ada/s-casi16.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -35,6 +35,12 @@ with Unchecked_Conversion;
package body System.Compare_Array_Signed_16 is
function "+" (Left, Right : Address) return Address;
pragma Import (Intrinsic, "+");
-- Provide addition operation on type Address (this may not be directly
-- available if type System.Address is non-private and the operations on
-- the type are made abstract to hide them from public users of System.
type Word is mod 2 ** 32;
-- Used to process operands by words

5
gcc/ada/s-casi16.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -44,8 +44,7 @@ package System.Compare_Array_Signed_16 is
(Left : System.Address;
Right : System.Address;
Left_Len : Natural;
Right_Len : Natural)
return Integer;
Right_Len : Natural) return Integer;
-- Compare the array starting at address Left of length Left_Len
-- with the array starting at address Right of length Right_Len.
-- The comparison is in the normal Ada semantic sense of array

8
gcc/ada/s-casi32.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -35,6 +35,12 @@ with Unchecked_Conversion;
package body System.Compare_Array_Signed_32 is
function "+" (Left, Right : Address) return Address;
pragma Import (Intrinsic, "+");
-- Provide addition operation on type Address (this may not be directly
-- available if type System.Address is non-private and the operations on
-- the type are made abstract to hide them from public users of System.
type Word is range -2**31 .. 2**31 - 1;
for Word'Size use 32;
-- Used to process operands by words

2
gcc/ada/s-casi32.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --

8
gcc/ada/s-casi64.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -35,6 +35,12 @@ with Unchecked_Conversion;
package body System.Compare_Array_Signed_64 is
function "+" (Left, Right : Address) return Address;
pragma Import (Intrinsic, "+");
-- Provide addition operation on type Address (this may not be directly
-- available if type System.Address is non-private and the operations on
-- the type are made abstract to hide them from public users of System.
type Word is range -2**63 .. 2**63 - 1;
for Word'Size use 64;
-- Used to process operands by words

5
gcc/ada/s-casi64.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -44,8 +44,7 @@ package System.Compare_Array_Signed_64 is
(Left : System.Address;
Right : System.Address;
Left_Len : Natural;
Right_Len : Natural)
return Integer;
Right_Len : Natural) return Integer;
-- Compare the array starting at address Left of length Left_Len
-- with the array starting at address Right of length Right_Len.
-- The comparison is in the normal Ada semantic sense of array

8
gcc/ada/s-caun16.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -35,6 +35,12 @@ with Unchecked_Conversion;
package body System.Compare_Array_Unsigned_16 is
function "+" (Left, Right : Address) return Address;
pragma Import (Intrinsic, "+");
-- Provide addition operation on type Address (this may not be directly
-- available if type System.Address is non-private and the operations on
-- the type are made abstract to hide them from public users of System.
type Word is mod 2 ** 32;
-- Used to process operands by words

5
gcc/ada/s-caun16.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -44,8 +44,7 @@ package System.Compare_Array_Unsigned_16 is
(Left : System.Address;
Right : System.Address;
Left_Len : Natural;
Right_Len : Natural)
return Integer;
Right_Len : Natural) return Integer;
-- Compare the array starting at address Left of length Left_Len
-- with the array starting at address Right of length Right_Len.
-- The comparison is in the normal Ada semantic sense of array

8
gcc/ada/s-caun32.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -35,6 +35,12 @@ with Unchecked_Conversion;
package body System.Compare_Array_Unsigned_32 is
function "+" (Left, Right : Address) return Address;
pragma Import (Intrinsic, "+");
-- Provide addition operation on type Address (this may not be directly
-- available if type System.Address is non-private and the operations on
-- the type are made abstract to hide them from public users of System.
type Word is mod 2 ** 32;
for Word'Size use 32;
-- Used to process operands by words

5
gcc/ada/s-caun32.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -44,8 +44,7 @@ package System.Compare_Array_Unsigned_32 is
(Left : System.Address;
Right : System.Address;
Left_Len : Natural;
Right_Len : Natural)
return Integer;
Right_Len : Natural) return Integer;
-- Compare the array starting at address Left of length Left_Len
-- with the array starting at address Right of length Right_Len.
-- The comparison is in the normal Ada semantic sense of array

8
gcc/ada/s-caun64.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -35,6 +35,12 @@ with Unchecked_Conversion;
package body System.Compare_Array_Unsigned_64 is
function "+" (Left, Right : Address) return Address;
pragma Import (Intrinsic, "+");
-- Provide addition operation on type Address (this may not be directly
-- available if type System.Address is non-private and the operations on
-- the type are made abstract to hide them from public users of System.
type Word is mod 2 ** 64;
-- Used to process operands by words

5
gcc/ada/s-caun64.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -44,8 +44,7 @@ package System.Compare_Array_Unsigned_64 is
(Left : System.Address;
Right : System.Address;
Left_Len : Natural;
Right_Len : Natural)
return Integer;
Right_Len : Natural) return Integer;
-- Compare the array starting at address Left of length Left_Len
-- with the array starting at address Right of length Right_Len.
-- The comparison is in the normal Ada semantic sense of array

17
gcc/ada/s-geveop.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -36,6 +36,21 @@ with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Conversion; use Ada;
package body System.Generic_Vector_Operations is
-- Provide arithmetic operations on type Address (these may not be
-- directly available if type System.Address is non-private and the
-- operations on the type are made abstract to hide them from public
-- users of System.
function "mod" (Left, Right : Address) return Address;
pragma Import (Intrinsic, "mod");
function "+" (Left, Right : Address) return Address;
pragma Import (Intrinsic, "+");
function "-" (Left, Right : Address) return Address;
pragma Import (Intrinsic, "-");
VU : constant Address := Vectors.Vector'Size / Storage_Unit;
EU : constant Address := Element_Array'Component_Size / Storage_Unit;

27
gcc/ada/s-parint.adb
View file

@ -7,7 +7,7 @@
-- B o d y --
-- (Dummy body for non-distributed case) --
-- --
-- Copyright (C) 1995-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1995-2004 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -162,20 +162,6 @@ package body System.Partition_Interface is
null;
end Get_Unique_Remote_Pointer;
------------
-- Launch --
------------
procedure Launch
(Rsh_Command : in String;
Name_Is_Host : in Boolean;
General_Name : in String;
Command_Line : in String)
is
begin
null;
end Launch;
-----------
-- Lower --
-----------
@ -195,17 +181,6 @@ package body System.Partition_Interface is
return T;
end Lower;
------------------------------------
-- Raise_Program_Error_For_E_4_18 --
------------------------------------
procedure Raise_Program_Error_For_E_4_18 is
begin
Ada.Exceptions.Raise_Exception
(Program_Error'Identity,
"Illegal usage of remote access to class-wide type. See RM E.4(18)");
end Raise_Program_Error_For_E_4_18;
-------------------------------------
-- Raise_Program_Error_Unknown_Tag --
-------------------------------------

19
gcc/ada/s-parint.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1995-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1995-2004 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -98,23 +98,6 @@ package System.Partition_Interface is
(Handler : in out RACW_Stub_Type_Access);
-- Get a unique pointer on a remote object
procedure Launch
(Rsh_Command : in String;
Name_Is_Host : in Boolean;
General_Name : in String;
Command_Line : in String);
-- General_Name represents the name of the machine or the name of the
-- partition (depending on the value of Name_Is_Host). Command_Line
-- holds the extra options that will be given on the command line.
-- Rsh_Command is typically "rsh", that will be used to launch the
-- other partition.
procedure Raise_Program_Error_For_E_4_18;
pragma No_Return (Raise_Program_Error_For_E_4_18);
-- Raise Program_Error with an error message explaining why it has been
-- raised. The rule in E.4 (18) is tricky and misleading for most users
-- of the distributed systems annex.
procedure Raise_Program_Error_Unknown_Tag
(E : in Ada.Exceptions.Exception_Occurrence);
pragma No_Return (Raise_Program_Error_Unknown_Tag);

2
gcc/ada/s-stalib.ads
View file

@ -97,7 +97,7 @@ package System.Standard_Library is
type Exception_Data_Ptr is access all Exception_Data;
-- An equivalent of Exception_Id that is public
type Exception_Code is mod 2 ** 32;
type Exception_Code is mod 2 ** Integer'Size;
-- A scalar value bound to some exception data. Typically used for
-- imported or exported exceptions on VMS. Having a separate type for this
-- is useful to enforce consistency throughout the various run-time units

8
gcc/ada/s-stoele.ads
View file

@ -51,12 +51,8 @@ pragma Pure (Storage_Elements);
-- and it would be unsafe to treat such functions as pure.
type Storage_Offset is range
-(2 ** (Standard."-" (Standard'Address_Size, 1))) ..
+(2 ** (Standard."-" (Standard'Address_Size, 1))) - 1;
-- Note: the reason for the qualification of "-" here by Standard is
-- that we have a current bug in GNAT that otherwise causes a bogus
-- ambiguity when this unit is analyzed in an Rtsfind context.
-(2 ** (Integer'(Standard'Address_Size) - 1)) ..
+(2 ** (Integer'(Standard'Address_Size) - 1)) - Long_Long_Integer'(1);
subtype Storage_Count is Storage_Offset range 0 .. Storage_Offset'Last;

201
gcc/ada/sem_ch3.adb
View file

@ -677,6 +677,16 @@ package body Sem_Ch3 is
Error_Msg_N ("task entries cannot have access parameters", N);
end if;
-- Ada 0Y (AI-254): In case of anonymous access to subprograms
-- call the corresponding semantic routine
if Present (Access_To_Subprogram_Definition (N)) then
Access_Subprogram_Declaration
(T_Name => Anon_Type,
T_Def => Access_To_Subprogram_Definition (N));
return Anon_Type;
end if;
Find_Type (Subtype_Mark (N));
Desig_Type := Entity (Subtype_Mark (N));
@ -818,6 +828,37 @@ package body Sem_Ch3 is
Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def));
-- -------------------------------------------------------------------
-- I assume that the following statements should also be here.
-- Need some tests to check it. Detected by comparison with the
-- access_definition subprogram???
-- -------------------------------------------------------------------
-- The anonymous access type is as public as the discriminated type or
-- subprogram that defines it. It is imported (for back-end purposes)
-- if the designated type is.
-- Set_Is_Public (T_Name, Is_Public (Scope (T_Name)));
-- Ada 0Y (AI-50217): Propagate the attribute that indicates that the
-- designated type comes from the limited view (for back-end purposes).
-- Set_From_With_Type (T_Name, From_With_Type (Desig_Type));
-- The context is either a subprogram declaration or an access
-- discriminant, in a private or a full type declaration. In
-- the case of a subprogram, If the designated type is incomplete,
-- the operation will be a primitive operation of the full type, to
-- be updated subsequently.
-- if Ekind (Desig_Type) = E_Incomplete_Type
-- and then Is_Overloadable (Current_Scope)
-- then
-- Append_Elmt (Current_Scope, Private_Dependents (Desig_Type));
-- Set_Has_Delayed_Freeze (Current_Scope);
-- end if;
-- ---------------------------------------------------------------
Check_Restriction (No_Access_Subprograms, T_Def);
end Access_Subprogram_Declaration;
@ -943,6 +984,17 @@ package body Sem_Ch3 is
(Related_Nod => N,
N => Access_Definition (Component_Definition (N)));
-- Ada 0Y (AI-254)
if Present (Access_To_Subprogram_Definition
(Access_Definition (Component_Definition (N))))
and then Protected_Present (Access_To_Subprogram_Definition
(Access_Definition
(Component_Definition (N))))
then
T := Replace_Anonymous_Access_To_Protected_Subprogram (N);
end if;
else
pragma Assert (False);
null;
@ -2932,6 +2984,17 @@ package body Sem_Ch3 is
(Related_Nod => Related_Id,
N => Access_Definition (Component_Def));
-- Ada 0Y (AI-254)
if Present (Access_To_Subprogram_Definition
(Access_Definition (Component_Def)))
and then Protected_Present (Access_To_Subprogram_Definition
(Access_Definition (Component_Def)))
then
Element_Type :=
Replace_Anonymous_Access_To_Protected_Subprogram (Def);
end if;
else
pragma Assert (False);
null;
@ -3074,6 +3137,93 @@ package body Sem_Ch3 is
end Array_Type_Declaration;
------------------------------------------------------
-- Replace_Anonymous_Access_To_Protected_Subprogram --
------------------------------------------------------
function Replace_Anonymous_Access_To_Protected_Subprogram
(N : Node_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (N);
Curr_Scope : constant Scope_Stack_Entry :=
Scope_Stack.Table (Scope_Stack.Last);
Anon : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
Acc : Node_Id;
Comp : Node_Id;
Decl : Node_Id;
P : Node_Id := Parent (N);
begin
Set_Is_Internal (Anon);
case Nkind (N) is
when N_Component_Declaration |
N_Unconstrained_Array_Definition |
N_Constrained_Array_Definition =>
Comp := Component_Definition (N);
Acc := Access_Definition (Component_Definition (N));
when N_Discriminant_Specification =>
Comp := Discriminant_Type (N);
Acc := Discriminant_Type (N);
when N_Parameter_Specification =>
Comp := Parameter_Type (N);
Acc := Parameter_Type (N);
when others =>
null;
pragma Assert (False);
end case;
Decl := Make_Full_Type_Declaration (Loc,
Defining_Identifier => Anon,
Type_Definition =>
Access_To_Subprogram_Definition (Acc));
Mark_Rewrite_Insertion (Decl);
-- Insert the new declaration in the nearest enclosing scope
while not Has_Declarations (P) loop
P := Parent (P);
end loop;
Prepend (Decl, Declarations (P));
-- Replace the anonymous type with an occurrence of the new declaration.
-- In all cases the rewriten node does not have the null-exclusion
-- attribute because (if present) it was already inherited by the
-- anonymous entity (Anon). Thus, in case of components we do not
-- inherit this attribute.
if Nkind (N) = N_Parameter_Specification then
Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
Set_Etype (Defining_Identifier (N), Anon);
Set_Null_Exclusion_Present (N, False);
else
Rewrite (Comp,
Make_Component_Definition (Loc,
Subtype_Indication => New_Occurrence_Of (Anon, Loc)));
end if;
Mark_Rewrite_Insertion (Comp);
-- Temporarily remove the current scope from the stack to add the new
-- declarations to the enclosing scope
Scope_Stack.Decrement_Last;
Analyze (Decl);
Scope_Stack.Append (Curr_Scope);
return Anon;
end Replace_Anonymous_Access_To_Protected_Subprogram;
-------------------------------
-- Build_Derived_Access_Type --
-------------------------------
@ -3425,6 +3575,7 @@ package body Sem_Ch3 is
else
Set_First_Entity (Derived_Type, First_Entity (Parent_Type));
if Has_Discriminants (Parent_Type) then
Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
Set_Discriminant_Constraint (
Derived_Type, Discriminant_Constraint (Parent_Type));
end if;
@ -3917,10 +4068,12 @@ package body Sem_Ch3 is
-- Copy declaration for subsequent analysis, to
-- provide a completion for what is a private
-- declaration.
-- declaration. Indicate that the full type is
-- internally generated.
Full_Decl := New_Copy_Tree (N);
Full_Der := New_Copy (Derived_Type);
Set_Comes_From_Source (Full_Decl, False);
Insert_After (N, Full_Decl);
@ -7916,10 +8069,9 @@ package body Sem_Ch3 is
Suffix : Character;
Suffix_Index : Nat)
is
Def_Id : Entity_Id;
R : Node_Id := Empty;
Checks_Off : Boolean := False;
T : constant Entity_Id := Etype (Index);
Def_Id : Entity_Id;
R : Node_Id := Empty;
T : constant Entity_Id := Etype (Index);
begin
if Nkind (S) = N_Range
@ -7933,21 +8085,7 @@ package body Sem_Ch3 is
Set_Etype (S, T);
R := S;
-- ??? Why on earth do we turn checks of in this very specific case ?
-- From the revision history: (Constrain_Index): Call
-- Process_Range_Expr_In_Decl with range checking off for range
-- bounds that are attributes. This avoids some horrible
-- constraint error checks.
if Nkind (R) = N_Range
and then Nkind (Low_Bound (R)) = N_Attribute_Reference
and then Nkind (High_Bound (R)) = N_Attribute_Reference
then
Checks_Off := True;
end if;
Process_Range_Expr_In_Decl (R, T, Empty_List, Checks_Off);
Process_Range_Expr_In_Decl (R, T, Empty_List);
if not Error_Posted (S)
and then
@ -9274,7 +9412,7 @@ package body Sem_Ch3 is
elsif Is_Unchecked_Union (Parent_Type) then
Error_Msg_N ("cannot derive from Unchecked_Union type", N);
-- Ada 0Y (AI-231)
-- Ada 0Y (AI-231): Static check
elsif Is_Access_Type (Parent_Type)
and then Null_Exclusion_Present (Type_Definition (N))
@ -11467,6 +11605,17 @@ package body Sem_Ch3 is
if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
Discr_Type := Access_Definition (N, Discriminant_Type (Discr));
-- Ada 0Y (AI-254)
if Present (Access_To_Subprogram_Definition
(Discriminant_Type (Discr)))
and then Protected_Present (Access_To_Subprogram_Definition
(Discriminant_Type (Discr)))
then
Discr_Type :=
Replace_Anonymous_Access_To_Protected_Subprogram (Discr);
end if;
else
Find_Type (Discriminant_Type (Discr));
Discr_Type := Etype (Discriminant_Type (Discr));
@ -11514,7 +11663,13 @@ package body Sem_Ch3 is
("discriminant defaults not allowed for formal type",
Expression (Discr));
elsif Is_Tagged_Type (Current_Scope) then
-- Tagged types cannot have defaulted discriminants, but a
-- non-tagged private type with defaulted discriminants
-- can have a tagged completion.
elsif Is_Tagged_Type (Current_Scope)
and then Comes_From_Source (N)
then
Error_Msg_N
("discriminants of tagged type cannot have defaults",
Expression (Discr));
@ -12310,7 +12465,7 @@ package body Sem_Ch3 is
Find_Type (S);
Check_Incomplete (S);
-- Ada 0Y (AI-231)
-- Ada 0Y (AI-231): Static check
if Extensions_Allowed
and then Present (Parent (S))

9
gcc/ada/sem_ch3.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -206,6 +206,13 @@ package Sem_Ch3 is
-- N_Incomplete_Type_Decl node N. If the declaration is a completion,
-- Prev is entity on the partial view, on which references are posted.
function Replace_Anonymous_Access_To_Protected_Subprogram
(N : Node_Id) return Entity_Id;
-- Ada 0Y (AI-254): Create and decorate an internal full type declaration
-- in the enclosing scope corresponding to an anonymous access to protected
-- subprogram. In addition, replace the anonymous access by an occurrence
-- of this internal type. Return the entity of this type declaration.
procedure Set_Completion_Referenced (E : Entity_Id);
-- If E is the completion of a private or incomplete type declaration,
-- or the completion of a deferred constant declaration, mark the entity

14
gcc/ada/sem_ch4.adb
View file

@ -2095,8 +2095,22 @@ package body Sem_Ch4 is
then
Error_Msg_NE
(" =='> in call to &#(inherited)!", Actual, Nam);
elsif Ekind (Nam) = E_Subprogram_Type then
declare
Access_To_Subprogram_Typ :
constant Entity_Id :=
Defining_Identifier
(Associated_Node_For_Itype (Nam));
begin
Error_Msg_NE (
" =='> in call to dereference of &#!",
Actual, Access_To_Subprogram_Typ);
end;
else
Error_Msg_NE (" =='> in call to &#!", Actual, Nam);
end if;
end if;
end if;

154
gcc/ada/sem_ch6.adb
View file

@ -4881,15 +4881,94 @@ package body Sem_Ch6 is
Parameter_Type (Param_Spec), Formal_Type);
end if;
-- Ada 0Y (AI-231): Create and decorate an internal subtype
-- declaration corresponding to the null-excluding type of the
-- formal in the enclosing scope. In addition, replace the
-- parameter type of the formal to this internal subtype.
if Null_Exclusion_Present (Param_Spec) then
declare
Loc : constant Source_Ptr := Sloc (Param_Spec);
Anon : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
Curr_Scope : constant Scope_Stack_Entry :=
Scope_Stack.Table (Scope_Stack.Last);
Ptype : constant Node_Id := Parameter_Type (Param_Spec);
Decl : Node_Id;
P : Node_Id := Parent (Parent (Related_Nod));
begin
Set_Is_Internal (Anon);
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Anon,
Null_Exclusion_Present => True,
Subtype_Indication =>
New_Occurrence_Of (Etype (Ptype), Loc));
-- Propagate the null-excluding attribute to the new entity
if Null_Exclusion_Present (Param_Spec) then
Set_Null_Exclusion_Present (Param_Spec, False);
Set_Can_Never_Be_Null (Anon);
end if;
Mark_Rewrite_Insertion (Decl);
-- Insert the new declaration in the nearest enclosing scope
while not Has_Declarations (P) loop
P := Parent (P);
end loop;
Prepend (Decl, Declarations (P));
Rewrite (Ptype, New_Occurrence_Of (Anon, Loc));
Mark_Rewrite_Insertion (Ptype);
-- Analyze the new declaration in the context of the
-- enclosing scope
Scope_Stack.Decrement_Last;
Analyze (Decl);
Scope_Stack.Append (Curr_Scope);
Formal_Type := Anon;
end;
end if;
-- Ada 0Y (AI-231): Static checks
if Null_Exclusion_Present (Param_Spec)
or else Can_Never_Be_Null (Entity (Ptype))
then
Null_Exclusion_Static_Checks (Param_Spec);
end if;
-- An access formal type
else
Formal_Type :=
Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
-- Ada 0Y (AI-254)
if Present (Access_To_Subprogram_Definition
(Parameter_Type (Param_Spec)))
and then Protected_Present (Access_To_Subprogram_Definition
(Parameter_Type (Param_Spec)))
then
Formal_Type :=
Replace_Anonymous_Access_To_Protected_Subprogram (Param_Spec);
end if;
end if;
Set_Etype (Formal, Formal_Type);
Default := Expression (Param_Spec);
if Present (Default) then
@ -4948,19 +5027,6 @@ package body Sem_Ch6 is
Apply_Scalar_Range_Check (Default, Formal_Type);
end if;
end if;
-- Ada 0Y (AI-231): Static checks
Ptype := Parameter_Type (Param_Spec);
if Extensions_Allowed
and then Nkind (Ptype) /= N_Access_Definition
and then (Null_Exclusion_Present (Parent (Formal))
or else Can_Never_Be_Null (Entity (Ptype)))
then
Null_Exclusion_Static_Checks (Param_Spec);
end if;
end if;
@ -5010,7 +5076,6 @@ package body Sem_Ch6 is
T : Entity_Id;
First_Stmt : Node_Id := Empty;
AS_Needed : Boolean;
Null_Exclusion : Boolean := False;
begin
-- If this is an emtpy initialization procedure, no need to create
@ -5065,17 +5130,6 @@ package body Sem_Ch6 is
then
AS_Needed := True;
-- Ada 0Y (AI-231)
elsif Extensions_Allowed
and then Is_Access_Type (T)
and then Null_Exclusion_Present (Parent (Formal))
and then Nkind (Parameter_Type (Parent (Formal)))
/= N_Access_Definition
then
AS_Needed := True;
Null_Exclusion := True;
-- All other cases do not need an actual subtype
else
@ -5086,40 +5140,7 @@ package body Sem_Ch6 is
-- unconstrained discriminated records.
if AS_Needed then
-- Ada 0Y (AI-231): Generate actual null-excluding subtype
if Extensions_Allowed
and then Null_Exclusion
then
declare
Loc : constant Source_Ptr := Sloc (Formal);
Anon : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('S'));
Ptype : constant Node_Id
:= Parameter_Type (Parent (Formal));
begin
-- T == Etype (Formal)
Set_Is_Internal (Anon);
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Anon,
Null_Exclusion_Present => True,
Subtype_Indication =>
New_Occurrence_Of (Etype (Ptype), Loc));
Mark_Rewrite_Insertion (Decl);
Prepend (Decl, Declarations (Parent (N)));
Rewrite (Ptype, New_Occurrence_Of (Anon, Loc));
Mark_Rewrite_Insertion (Ptype);
-- Set_Scope (Anon, Scope (Scope (Formal)));
Set_Etype (Formal, Anon);
Set_Null_Exclusion_Present (Parent (Formal), False);
end;
elsif Nkind (N) = N_Accept_Statement then
if Nkind (N) = N_Accept_Statement then
-- If expansion is active, The formal is replaced by a local
-- variable that renames the corresponding entry of the
@ -5151,17 +5172,10 @@ package body Sem_Ch6 is
Mark_Rewrite_Insertion (Decl);
end if;
Analyze (Decl);
-- The declaration uses the bounds of an existing object,
-- and therefore needs no constraint checks.
-- Ada 0Y (AI-231): Previous analysis leaves the entity of the
-- null-excluding subtype declaration associated with the internal
-- scope; because this declaration has been inserted before the
-- subprogram we associate it now with the enclosing scope.
if Null_Exclusion then
Set_Scope (Defining_Identifier (Decl),
Scope (Scope (Formal)));
end if;
Analyze (Decl, Suppress => All_Checks);
-- We need to freeze manually the generated type when it is
-- inserted anywhere else than in a declarative part.

10
gcc/ada/sem_ch8.adb
View file

@ -683,10 +683,16 @@ package body Sem_Ch8 is
T := Entity (Subtype_Mark (N));
Analyze_And_Resolve (Nam, T);
-- Ada 0Y (AI-230): Access renaming
-- Ada 0Y (AI-230/AI-254): Access renaming
elsif Present (Access_Definition (N)) then
Find_Type (Subtype_Mark (Access_Definition (N)));
if Null_Exclusion_Present (Access_Definition (N)) then
Error_Msg_N ("(Ada 0Y): null-excluding attribute ignored "
& "('R'M 8.5.1(6))?", N);
Set_Null_Exclusion_Present (Access_Definition (N), False);
end if;
T := Access_Definition
(Related_Nod => N,
N => Access_Definition (N));

46
gcc/ada/sem_dist.adb
View file

@ -151,47 +151,6 @@ package body Sem_Dist is
return End_String;
end Full_Qualified_Name;
-----------------------
-- Get_Subprogram_Id --
-----------------------
function Get_Subprogram_Id (E : Entity_Id) return Int is
Current_Declaration : Node_Id;
Result : Int := 0;
begin
pragma Assert
(Is_Remote_Call_Interface (Scope (E))
and then
(Nkind (Parent (E)) = N_Procedure_Specification
or else
Nkind (Parent (E)) = N_Function_Specification));
Current_Declaration :=
First (Visible_Declarations
(Package_Specification_Of_Scope (Scope (E))));
while Current_Declaration /= Empty loop
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
if Defining_Unit_Name
(Specification (Current_Declaration)) = E
then
return Result;
end if;
Result := Result + 1;
end if;
Next (Current_Declaration);
end loop;
-- Error if we do not find it
raise Program_Error;
end Get_Subprogram_Id;
------------------------
-- Is_All_Remote_Call --
------------------------
@ -334,7 +293,6 @@ package body Sem_Dist is
RS_Pkg_E : Entity_Id;
RAS_Type : Entity_Id;
Async_E : Entity_Id;
Subp_Id : Int;
Attribute_Subp : Entity_Id;
Parameter : Node_Id;
@ -373,8 +331,6 @@ package body Sem_Dist is
RS_Pkg_Specif := Parent (Remote_Subp_Decl);
RS_Pkg_E := Defining_Entity (RS_Pkg_Specif);
Subp_Id := Get_Subprogram_Id (Remote_Subp);
if Ekind (Remote_Subp) = E_Procedure
and then Is_Asynchronous (Remote_Subp)
then
@ -392,7 +348,7 @@ package body Sem_Dist is
New_List (
Parameter,
Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
Make_Integer_Literal (Loc, Subp_Id),
Build_Subprogram_Id (Loc, Remote_Subp),
New_Occurrence_Of (Async_E, Loc)));
Rewrite (N, Tick_Access_Conv_Call);

6
gcc/ada/sem_dist.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -83,10 +83,6 @@ package Sem_Dist is
-- aggregate and will return True in this case. Otherwise, it will
-- return False.
function Get_Subprogram_Id (E : Entity_Id) return Int;
-- Given a subprogram defined in a RCI package, get its subprogram id
-- which will be used for remote calls.
function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id;
-- Return the N_Package_Specification corresponding to a scope E

Some files were not shown because too many files have changed in this diff Show more