diff options
| author | Arnaud Charlet <charlet@gcc.gnu.org> | 2004-04-19 17:20:16 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2004-04-19 17:20:16 +0200 |
| commit | 7324bf49ceb4aaca385ae0c32095901b96a2c969 (patch) | |
| tree | 978d1dfc5330e89503dce76f1c63cf981f4b9d73 /gcc/ada | |
| parent | 10b5935eb21a9828cf77e08e2b7e43238be7df40 (diff) | |
| download | gcc-7324bf49ceb4aaca385ae0c32095901b96a2c969.zip gcc-7324bf49ceb4aaca385ae0c32095901b96a2c969.tar.gz gcc-7324bf49ceb4aaca385ae0c32095901b96a2c969.tar.bz2 | |
[multiple changes]
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
Diffstat (limited to 'gcc/ada')
118 files changed, 5218 insertions, 3032 deletions
diff --git a/gcc/ada/5aml-tgt.adb b/gcc/ada/5aml-tgt.adb index 85bd715..2474da3 100644 --- a/gcc/ada/5aml-tgt.adb +++ b/gcc/ada/5aml-tgt.adb @@ -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 -- ---------------- diff --git a/gcc/ada/5bml-tgt.adb b/gcc/ada/5bml-tgt.adb index c07d58c..c95d648 100644 --- a/gcc/ada/5bml-tgt.adb +++ b/gcc/ada/5bml-tgt.adb @@ -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 -- ---------------- diff --git a/gcc/ada/5gml-tgt.adb b/gcc/ada/5gml-tgt.adb index cc13d37..c188199 100644 --- a/gcc/ada/5gml-tgt.adb +++ b/gcc/ada/5gml-tgt.adb @@ -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 -- ---------------- diff --git a/gcc/ada/5hml-tgt.adb b/gcc/ada/5hml-tgt.adb index a8cbc79..4eb2934 100644 --- a/gcc/ada/5hml-tgt.adb +++ b/gcc/ada/5hml-tgt.adb @@ -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 -- ---------------- diff --git a/gcc/ada/5isystem.ads b/gcc/ada/5isystem.ads deleted file mode 100644 index b418fd2..0000000 --- a/gcc/ada/5isystem.ads +++ /dev/null @@ -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; diff --git a/gcc/ada/5lml-tgt.adb b/gcc/ada/5lml-tgt.adb index fbe5054..00ab392 100644 --- a/gcc/ada/5lml-tgt.adb +++ b/gcc/ada/5lml-tgt.adb @@ -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 -- ---------------- diff --git a/gcc/ada/5omastop.adb b/gcc/ada/5omastop.adb index aa704d3..96ac113 100644 --- a/gcc/ada/5omastop.adb +++ b/gcc/ada/5omastop.adb @@ -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; diff --git a/gcc/ada/5sml-tgt.adb b/gcc/ada/5sml-tgt.adb index f4facc9..ac5e4b9 100644 --- a/gcc/ada/5sml-tgt.adb +++ b/gcc/ada/5sml-tgt.adb @@ -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 -- ---------------- diff --git a/gcc/ada/5vml-tgt.adb b/gcc/ada/5vml-tgt.adb index 851ccf7..6db0dcc 100644 --- a/gcc/ada/5vml-tgt.adb +++ b/gcc/ada/5vml-tgt.adb @@ -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; + + if OK then + Len := Write + (Macro_File, First_Line (First_Line'First)'Address, + First_Line'Length); + OK := Len = First_Line'Length; + end if; - 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, Second_Line (Second_Line'First)'Address, + Second_Line'Length); + OK := Len = Second_Line'Length; + end if; - Close (Macro_File); + if OK then + Close (Macro_File, OK); + end if; - exception - when others => + 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 -- ---------------- diff --git a/gcc/ada/5wml-tgt.adb b/gcc/ada/5wml-tgt.adb index 5747ead..485be34 100644 --- a/gcc/ada/5wml-tgt.adb +++ b/gcc/ada/5wml-tgt.adb @@ -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 -- ---------------- diff --git a/gcc/ada/5zml-tgt.adb b/gcc/ada/5zml-tgt.adb index c1ae724..9b3f575 100644 --- a/gcc/ada/5zml-tgt.adb +++ b/gcc/ada/5zml-tgt.adb @@ -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 -- ---------------- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2e6bb52..ae718b0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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. diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 072c9e8..ad17a50 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -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" diff --git a/gcc/ada/a-calend.adb b/gcc/ada/a-calend.adb index 1715d7f..fdab0cb 100644 --- a/gcc/ada/a-calend.adb +++ b/gcc/ada/a-calend.adb @@ -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. - - while Year_Val <= Unix_Year_Min loop - Year_Val := Year_Val + 4; - Duration_Adjust := Duration_Adjust - Seconds_In_4_YearsD; + -- 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 + 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; diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 8e9e98c..c07790a 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -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 -- ------------- diff --git a/gcc/ada/ada-tree.def b/gcc/ada/ada-tree.def index e58963e..e5fe7eb 100644 --- a/gcc/ada/ada-tree.def +++ b/gcc/ada/ada-tree.def @@ -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) diff --git a/gcc/ada/ada-tree.h b/gcc/ada/ada-tree.h index 572a5b7..3f6faed 100644 --- a/gcc/ada/ada-tree.h +++ b/gcc/ada/ada-tree.h @@ -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) diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 67a457c..58d955a 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -1472,6 +1472,20 @@ __gnat_set_writable (char *name) } 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) { #ifndef __vxworks diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index def011c..66f234e 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -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 *[]); diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 49938b9..c03a183 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -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; + pragma Assert (not (Has_Extension (Node))); + Result := Allocate_Initialize_Node (Node, With_Extension => True); + pragma Debug (Debug_Extend_Node); + return Result; + end Extend_Node; - else - Result := Node; - end if; + ----------------- + -- Fix_Parents -- + ----------------- - 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; + procedure Fix_Parents (Old_Node, New_Node : Node_Id) is - Orig_Nodes.Set_Last (Nodes.Last); - Allocate_List_Tables (Nodes.Last); + 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. - pragma Debug (Debug_Extend_Node); - return Result; - end Extend_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. - ---------------- - -- Fix_Parent -- - ---------------- + 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); - 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 - -- 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; - 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; + begin + 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; - Nodes.Table (New_Id).Rewrite_Ins := False; - Orig_Nodes.Increment_Last; - Orig_Nodes.Table (New_Id) := New_Id; + -- If the original is marked as a rewrite insertion, then unmark + -- the copy, since we inserted the original, not the copy. - 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; + Nodes.Table (New_Id).Rewrite_Ins := False; 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; ------------------ diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index ea73f2f..aaad1a4 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -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 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 - procedure Must_Be_Initialized is + -------------------------- + -- 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); - - 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 Must_Be_Initialized; + 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; - ---------------------- - -- Null_Not_Allowed -- - ---------------------- + --------------------------------------- + -- Check_Already_Null_Excluding_Type -- + --------------------------------------- - 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); - - 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 Null_Not_Allowed; + 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; + + ------------------------------- + -- Check_Must_Be_Initialized -- + ------------------------------- + + 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; - - if Nkind (Discriminant_Type (N)) = N_Access_Definition then + Msg_K := Components; - -- 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; ---------------------------------- diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index 5b0581f..83bfec0 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -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); diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb index 2a5357c..d083c32 100644 --- a/gcc/ada/eval_fat.adb +++ b/gcc/ada/eval_fat.adb @@ -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 -- ----------- diff --git a/gcc/ada/eval_fat.ads b/gcc/ada/eval_fat.ads index 451326d..4f24569 100644 --- a/gcc/ada/eval_fat.ads +++ b/gcc/ada/eval_fat.ads @@ -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; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 37d9a61..8dd7492 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 28ece68..040377e 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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) diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 0cde2a6..60a1147 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -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)) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index c9de061..aec5571 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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 diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 1bfb5c1..c9d59c2 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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. - - 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; + 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)); + + 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); - - Insert_Actions (N, New_List (Decl)); - Rewrite (N, New_Occurrence_Of (Temp_Obj, Loc)); - end; + 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; + + 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 diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index f60980a..c712eac 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -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; diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index aa47c00..be3eee5 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -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; - end if; - end loop; - - -- Case of $ used for homonym numbers suffix - - 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 + 1); - SL := Name_Len - J; + 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; - 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; - exit; - end if; - end loop; - end if; end Strip_Suffixes; end Exp_Dbug; diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 4204cac..51dd15e 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -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 -- ---------- diff --git a/gcc/ada/exp_dist.ads b/gcc/ada/exp_dist.ads index 648803c..10cbc60 100644 --- a/gcc/ada/exp_dist.ads +++ b/gcc/ada/exp_dist.ads @@ -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; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index f688909..9fe4052 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -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))) diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index d79ec31..e38bcce 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 62568f5..2382207 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -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 diff --git a/gcc/ada/get_targ.ads b/gcc/ada/get_targ.ads index 9d115f0..f3d62ff 100644 --- a/gcc/ada/get_targ.ads +++ b/gcc/ada/get_targ.ads @@ -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"); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index b3097a1..0c64029 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -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. diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index b793b48..3ef0e32 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -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); diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 5292079..0b9bd2a 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -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 -- ------------------ diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index c667251..6b3d07e 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -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. diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 119d184..e175766 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -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); diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index 124ca39..e726c2d 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -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 -- --------------- diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index 2a94f86..d45ccfb 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -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 diff --git a/gcc/ada/link.c b/gcc/ada/link.c index e16978e..a7ae922 100644 --- a/gcc/ada/link.c +++ b/gcc/ada/link.c @@ -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; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 3587599..264527e 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -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; - - 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; + Linker_Options : constant String_List := + Linker_Options_Switches (Main_Project); - 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; diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb index 73e91f1..49b7a0d 100644 --- a/gcc/ada/makeusg.adb +++ b/gcc/ada/makeusg.adb @@ -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"); diff --git a/gcc/ada/mdll-utl.adb b/gcc/ada/mdll-utl.adb index 2608e92..80da0eb 100644 --- a/gcc/ada/mdll-utl.adb +++ b/gcc/ada/mdll-utl.adb @@ -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); + + 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); + 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); + + 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); + 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; - end if; + 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; diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 612845c..70d8741 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -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; ------------------ diff --git a/gcc/ada/mlib-tgt.adb b/gcc/ada/mlib-tgt.adb index 6cebb5c..dc13773 100644 --- a/gcc/ada/mlib-tgt.adb +++ b/gcc/ada/mlib-tgt.adb @@ -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 -- ---------------- diff --git a/gcc/ada/mlib-tgt.ads b/gcc/ada/mlib-tgt.ads index a645895..5d142ae 100644 --- a/gcc/ada/mlib-tgt.ads +++ b/gcc/ada/mlib-tgt.ads @@ -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; diff --git a/gcc/ada/mlib.adb b/gcc/ada/mlib.adb index 5016587..3cefb6d 100644 --- a/gcc/ada/mlib.adb +++ b/gcc/ada/mlib.adb @@ -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 - if Hostparm.OpenVMS then - - -- Copy_Attributes always fails on VMS + -- Copy_Attributes always fails on VMS + if Hostparm.OpenVMS then Preserve := None; end if; end MLib; diff --git a/gcc/ada/mlib.ads b/gcc/ada/mlib.ads index c844ccb..eb9b3fe 100644 --- a/gcc/ada/mlib.ads +++ b/gcc/ada/mlib.ads @@ -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; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 77468fa..9fea924 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -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. diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index c109d3f..dad0101 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -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); - 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 + if Aliased_Present then + Error_Msg_SP ("ALIASED not allowed here"); 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, Empty); + Set_Aliased_Present (CompDef_Node, False); + Set_Access_Definition (CompDef_Node, + P_Access_Definition (Not_Null_Present)); + else - 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; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 3d7e270..406545d 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -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 diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 23f280c..941d7d2 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -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; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 2d86577..85a2fde 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -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; diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 5fd8290..ba2b04f 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -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. diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index e5e6bf9..32dd376 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.ads @@ -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 diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 5b09f84..f49af20 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -52,9 +52,14 @@ with GNAT.HTable; package body Prj.Nmsc is - Error_Report : Put_Line_Access := null; + Error_Report : Put_Line_Access := null; + -- Set to point to error reporting procedure - ALI_Suffix : constant String := ".ali"; + ALI_Suffix : constant String := ".ali"; + -- File suffix for ali files + + Object_Suffix : constant String := Get_Object_Suffix.all; + -- File suffix for object files type Name_Location is record Name : Name_Id; @@ -92,6 +97,33 @@ package body Prj.Nmsc is -- several times, and to avoid cycles that may be introduced by symbolic -- links. + type Unit_Info is record + Kind : Spec_Or_Body; + Unit : Name_Id; + end record; + No_Unit : constant Unit_Info := (Specification, No_Name); + + package Ada_Naming_Exceptions is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Unit_Info, + No_Element => No_Unit, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- A hash table to store naming exceptions for Ada + + function Hash (Unit : Unit_Info) return Header_Num; + + package Reverse_Ada_Naming_Exceptions is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Name_Id, + No_Element => No_Name, + Key => Unit_Info, + Hash => Hash, + Equal => "="); + -- A table to check if a unit with an exceptional name will hide + -- a source with a file name following the naming convention. + function ALI_File_Name (Source : String) return String; -- Return the ALI file name corresponding to a source. @@ -105,6 +137,34 @@ package body Prj.Nmsc is Unit : out Name_Id); -- Check that a name is a valid Ada unit name. + procedure Check_For_Source + (File_Name : Name_Id; + Path_Name : Name_Id; + Project : Project_Id; + Data : in out Project_Data; + Location : Source_Ptr; + Language : Other_Programming_Language; + Suffix : String; + Naming_Exception : Boolean); + -- Check if a file in a source directory is a source for a specific + -- language other than Ada. + + procedure Check_Naming_Scheme + (Data : in out Project_Data; + Project : Project_Id); + -- Check the naming scheme part of Data + + function Check_Project + (P : Project_Id; + Root_Project : Project_Id; + Extending : Boolean) return Boolean; + -- Returns True if P is Root_Project or, if Extending is True, a project + -- extended by Root_Project. + + function Compute_Directory_Last (Dir : String) return Natural; + -- Return the index of the last significant character in Dir. This is used + -- to avoid duplicates '/' at the end of directory names + procedure Error_Msg (Project : Project_Id; Msg : String; @@ -113,6 +173,28 @@ package body Prj.Nmsc is -- Prj.Err.Error_Msg. Otherwise, disregard Flag_Location and use -- Error_Report. + procedure Find_Sources + (Project : Project_Id; + Data : in out Project_Data; + For_Language : Programming_Language; + Follow_Links : Boolean := False); + -- Find all the sources in all of the source directories of a project for + -- a specified language. + + procedure Free_Ada_Naming_Exceptions; + -- Free the internal hash tables used for checking naming exceptions + + procedure Get_Mains (Project : Project_Id; Data : in out Project_Data); + -- Get the mains of a project from attribute Main, if it exists, and put + -- them in the project data. + + procedure Get_Sources_From_File + (Path : String; + Location : Source_Ptr; + Project : Project_Id); + -- Get the list of sources from a text file and put them in hash table + -- Source_Names. + procedure Get_Unit (Canonical_File_Name : Name_Id; Naming : Naming_Data; @@ -129,21 +211,6 @@ package body Prj.Nmsc is -- Returns True if the string Suffix cannot be used as -- a spec suffix, a body suffix or a separate suffix. - procedure Record_Source - (File_Name : Name_Id; - Path_Name : Name_Id; - Project : Project_Id; - Data : in out Project_Data; - Location : Source_Ptr; - Current_Source : in out String_List_Id; - Source_Recorded : in out Boolean; - Trusted_Mode : Boolean); - -- Put a unit in the list of units of a project, if the file name - -- corresponds to a valid unit name. - - procedure Show_Source_Dirs (Project : Project_Id); - -- List all the source directories of a project. - procedure Locate_Directory (Name : Name_Id; Parent : Name_Id; @@ -158,429 +225,46 @@ package body Prj.Nmsc is -- Returns the path name of a (non project) file. -- Returns an empty string if file cannot be found. + procedure Prepare_Ada_Naming_Exceptions + (List : Array_Element_Id; + Kind : Spec_Or_Body); + -- Prepare the internal hash tables used for checking naming exceptions + -- for Ada. Insert all elements of List in the tables. + function Project_Extends (Extending : Project_Id; Extended : Project_Id) return Boolean; -- Returns True if Extending is extending directly or indirectly Extended. - procedure Check_Naming_Scheme - (Data : in out Project_Data; - Project : Project_Id); - -- Check the naming scheme part of Data - - type Unit_Info is record - Kind : Spec_Or_Body; - Unit : Name_Id; - end record; - No_Unit : constant Unit_Info := (Specification, No_Name); - - package Naming_Exceptions is new GNAT.HTable.Simple_HTable - (Header_Num => Header_Num, - Element => Unit_Info, - No_Element => No_Unit, - Key => Name_Id, - Hash => Hash, - Equal => "="); - - function Hash (Unit : Unit_Info) return Header_Num; - - package Reverse_Naming_Exceptions is new GNAT.HTable.Simple_HTable - (Header_Num => Header_Num, - Element => Name_Id, - No_Element => No_Name, - Key => Unit_Info, - Hash => Hash, - Equal => "="); - -- A table to check if a unit with an exceptional name will hide - -- a source with a file name following the naming convention. - - procedure Prepare_Naming_Exceptions - (List : Array_Element_Id; - Kind : Spec_Or_Body); - -- Prepare the internal hash tables used for checking naming exceptions. - -- Insert all elements of List in the tables. - - procedure Free_Naming_Exceptions; - -- Free the internal hash tables used for checking naming exceptions - - function Compute_Directory_Last (Dir : String) return Natural; - -- Return the index of the last significant character in Dir. This is used - -- to avoid duplicates '/' at the end of directory names - - ---------------------------- - -- Compute_Directory_Last -- - ---------------------------- - - function Compute_Directory_Last (Dir : String) return Natural is - begin - if Dir'Length > 1 - and then (Dir (Dir'Last - 1) = Directory_Separator - or else Dir (Dir'Last - 1) = '/') - then - return Dir'Last - 1; - else - return Dir'Last; - end if; - end Compute_Directory_Last; - - ------------------------------- - -- Prepare_Naming_Exceptions -- - ------------------------------- - - procedure Prepare_Naming_Exceptions - (List : Array_Element_Id; - Kind : Spec_Or_Body) - is - Current : Array_Element_Id := List; - Element : Array_Element; - - begin - while Current /= No_Array_Element loop - Element := Array_Elements.Table (Current); - - if Element.Index /= No_Name then - Naming_Exceptions.Set - (Element.Value.Value, - (Kind => Kind, Unit => Element.Index)); - Reverse_Naming_Exceptions.Set - ((Kind => Kind, Unit => Element.Index), - Element.Value.Value); - end if; - - Current := Element.Next; - end loop; - end Prepare_Naming_Exceptions; - - ---------- - -- Hash -- - ---------- - - function Hash (Unit : Unit_Info) return Header_Num is - begin - return Header_Num (Unit.Unit mod 2048); - end Hash; - - ---------------------------- - -- Free_Naming_Exceptions -- - ---------------------------- - - procedure Free_Naming_Exceptions is - begin - Naming_Exceptions.Reset; - Reverse_Naming_Exceptions.Reset; - end Free_Naming_Exceptions; - - ------------------------- - -- Check_Naming_Scheme -- - ------------------------- - - procedure Check_Naming_Scheme - (Data : in out Project_Data; - Project : Project_Id) - is - Naming_Id : constant Package_Id := - Util.Value_Of (Name_Naming, Data.Decl.Packages); - - Naming : Package_Element; - - procedure Check_Unit_Names (List : Array_Element_Id); - -- Check that a list of unit names contains only valid names. - - ---------------------- - -- Check_Unit_Names -- - ---------------------- - - procedure Check_Unit_Names (List : Array_Element_Id) is - Current : Array_Element_Id := List; - Element : Array_Element; - Unit_Name : Name_Id; - - begin - -- Loop through elements of the string list - - while Current /= No_Array_Element loop - Element := Array_Elements.Table (Current); - - -- Put file name in canonical case - - Get_Name_String (Element.Value.Value); - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Element.Value.Value := Name_Find; - - -- Check that it contains a valid unit name - - Get_Name_String (Element.Index); - Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit_Name); - - if Unit_Name = No_Name then - Err_Vars.Error_Msg_Name_1 := Element.Index; - Error_Msg - (Project, - "{ is not a valid unit name.", - Element.Value.Location); - - else - if Current_Verbosity = High then - Write_Str (" Unit ("""); - Write_Str (Get_Name_String (Unit_Name)); - Write_Line (""")"); - end if; - - Element.Index := Unit_Name; - Array_Elements.Table (Current) := Element; - end if; - - Current := Element.Next; - end loop; - end Check_Unit_Names; - - -- Start of processing for Check_Naming_Scheme - - begin - -- If there is a package Naming, we will put in Data.Naming what is in - -- this package Naming. - - if Naming_Id /= No_Package then - Naming := Packages.Table (Naming_Id); - - if Current_Verbosity = High then - Write_Line ("Checking ""Naming"" for Ada."); - end if; - - declare - Bodies : constant Array_Element_Id := - Util.Value_Of (Name_Body, Naming.Decl.Arrays); - - Specs : constant Array_Element_Id := - Util.Value_Of (Name_Spec, Naming.Decl.Arrays); - - begin - if Bodies /= No_Array_Element then - - -- We have elements in the array Body_Part - - if Current_Verbosity = High then - Write_Line ("Found Bodies."); - end if; - - Data.Naming.Bodies := Bodies; - Check_Unit_Names (Bodies); - - else - if Current_Verbosity = High then - Write_Line ("No Bodies."); - end if; - end if; - - if Specs /= No_Array_Element then - - -- We have elements in the array Specs - - if Current_Verbosity = High then - Write_Line ("Found Specs."); - end if; - - Data.Naming.Specs := Specs; - Check_Unit_Names (Specs); - - else - if Current_Verbosity = High then - Write_Line ("No Specs."); - end if; - end if; - end; - - -- We are now checking if variables Dot_Replacement, Casing, - -- Spec_Suffix, Body_Suffix and/or Separate_Suffix - -- exist. - - -- For each variable, if it does not exist, we do nothing, - -- because we already have the default. - - -- Check Dot_Replacement - - declare - Dot_Replacement : constant Variable_Value := - Util.Value_Of - (Name_Dot_Replacement, - Naming.Decl.Attributes); - - begin - pragma Assert (Dot_Replacement.Kind = Single, - "Dot_Replacement is not a single string"); - - if not Dot_Replacement.Default then - Get_Name_String (Dot_Replacement.Value); - - if Name_Len = 0 then - Error_Msg - (Project, - "Dot_Replacement cannot be empty", - Dot_Replacement.Location); - - else - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Data.Naming.Dot_Replacement := Name_Find; - Data.Naming.Dot_Repl_Loc := Dot_Replacement.Location; - end if; - end if; - end; - - if Current_Verbosity = High then - Write_Str (" Dot_Replacement = """); - Write_Str (Get_Name_String (Data.Naming.Dot_Replacement)); - Write_Char ('"'); - Write_Eol; - end if; - - -- Check Casing - - declare - Casing_String : constant Variable_Value := - Util.Value_Of - (Name_Casing, Naming.Decl.Attributes); - - begin - pragma Assert (Casing_String.Kind = Single, - "Casing is not a single string"); - - if not Casing_String.Default then - declare - Casing_Image : constant String := - Get_Name_String (Casing_String.Value); - begin - declare - Casing : constant Casing_Type := Value (Casing_Image); - begin - Data.Naming.Casing := Casing; - end; - - exception - when Constraint_Error => - if Casing_Image'Length = 0 then - Error_Msg - (Project, - "Casing cannot be an empty string", - Casing_String.Location); - - else - Name_Len := Casing_Image'Length; - Name_Buffer (1 .. Name_Len) := Casing_Image; - Err_Vars.Error_Msg_Name_1 := Name_Find; - Error_Msg - (Project, - "{ is not a correct Casing", - Casing_String.Location); - end if; - end; - end if; - end; - - if Current_Verbosity = High then - Write_Str (" Casing = "); - Write_Str (Image (Data.Naming.Casing)); - Write_Char ('.'); - Write_Eol; - end if; - - -- Check Spec_Suffix - - declare - Ada_Spec_Suffix : constant Variable_Value := - Prj.Util.Value_Of - (Index => Name_Ada, - In_Array => Data.Naming.Spec_Suffix); - - begin - if Ada_Spec_Suffix.Kind = Single - and then Get_Name_String (Ada_Spec_Suffix.Value) /= "" - then - Data.Naming.Current_Spec_Suffix := Ada_Spec_Suffix.Value; - Data.Naming.Spec_Suffix_Loc := Ada_Spec_Suffix.Location; - - else - Data.Naming.Current_Spec_Suffix := Default_Ada_Spec_Suffix; - end if; - end; - - if Current_Verbosity = High then - Write_Str (" Spec_Suffix = """); - Write_Str (Get_Name_String (Data.Naming.Current_Spec_Suffix)); - Write_Char ('"'); - Write_Eol; - end if; - - -- Check Body_Suffix - - declare - Ada_Body_Suffix : constant Variable_Value := - Prj.Util.Value_Of - (Index => Name_Ada, - In_Array => Data.Naming.Body_Suffix); - - begin - if Ada_Body_Suffix.Kind = Single - and then Get_Name_String (Ada_Body_Suffix.Value) /= "" - then - Data.Naming.Current_Body_Suffix := Ada_Body_Suffix.Value; - Data.Naming.Body_Suffix_Loc := Ada_Body_Suffix.Location; - - else - Data.Naming.Current_Body_Suffix := Default_Ada_Body_Suffix; - end if; - end; - - if Current_Verbosity = High then - Write_Str (" Body_Suffix = """); - Write_Str (Get_Name_String (Data.Naming.Current_Body_Suffix)); - Write_Char ('"'); - Write_Eol; - end if; - - -- Check Separate_Suffix - - declare - Ada_Sep_Suffix : constant Variable_Value := - Prj.Util.Value_Of - (Variable_Name => Name_Separate_Suffix, - In_Variables => Naming.Decl.Attributes); - - begin - if Ada_Sep_Suffix.Default then - Data.Naming.Separate_Suffix := - Data.Naming.Current_Body_Suffix; - - else - if Get_Name_String (Ada_Sep_Suffix.Value) = "" then - Error_Msg - (Project, - "Separate_Suffix cannot be empty", - Ada_Sep_Suffix.Location); - - else - Data.Naming.Separate_Suffix := Ada_Sep_Suffix.Value; - Data.Naming.Sep_Suffix_Loc := Ada_Sep_Suffix.Location; - end if; - end if; - end; - - if Current_Verbosity = High then - Write_Str (" Separate_Suffix = """); - Write_Str (Get_Name_String (Data.Naming.Separate_Suffix)); - Write_Char ('"'); - Write_Eol; - end if; + procedure Record_Ada_Source + (File_Name : Name_Id; + Path_Name : Name_Id; + Project : Project_Id; + Data : in out Project_Data; + Location : Source_Ptr; + Current_Source : in out String_List_Id; + Source_Recorded : in out Boolean; + Follow_Links : Boolean); + -- Put a unit in the list of units of a project, if the file name + -- corresponds to a valid unit name. - -- Check if Data.Naming is valid + procedure Record_Other_Sources + (Project : Project_Id; + Data : in out Project_Data; + Language : Programming_Language; + Naming_Exceptions : Boolean); + -- Record the sources of a language in a project. + -- When Naming_Exceptions is True, mark the found sources as such, to + -- later remove those that are not named in a list of sources. - Check_Ada_Naming_Scheme (Project, Data.Naming); + procedure Show_Source_Dirs (Project : Project_Id); + -- List all the source directories of a project. - else - Data.Naming.Current_Spec_Suffix := Default_Ada_Spec_Suffix; - Data.Naming.Current_Body_Suffix := Default_Ada_Body_Suffix; - Data.Naming.Separate_Suffix := Default_Ada_Body_Suffix; - end if; - end Check_Naming_Scheme; + function Suffix_For + (Language : Programming_Language; + Naming : Naming_Data) return Name_Id; + -- Get the suffix for the source of a language from a package naming. + -- If not specified, return the default for the language. --------------- -- Ada_Check -- @@ -589,20 +273,13 @@ package body Prj.Nmsc is procedure Ada_Check (Project : Project_Id; Report_Error : Put_Line_Access; - Trusted_Mode : Boolean) + Follow_Links : Boolean) is Data : Project_Data; Languages : Variable_Value := Nil_Variable_Value; Extending : Boolean := False; - function Check_Project (P : Project_Id) return Boolean; - -- Returns True if P is Project or a project extended by Project - - procedure Find_Sources; - -- Find all the sources in all of the source directories - -- of a project. - procedure Get_Path_Names_And_Record_Sources; -- Find the path names of the source files in the Source_Names table -- in the source directories and record those that are Ada sources. @@ -618,157 +295,6 @@ package body Prj.Nmsc is -- Check that individual naming conventions apply to immediate -- sources of the project; if not, issue a warning. - ------------------- - -- Check_Project -- - ------------------- - - function Check_Project (P : Project_Id) return Boolean is - begin - if P = Project then - return True; - elsif Extending then - declare - Data : Project_Data := Projects.Table (Project); - - begin - while Data.Extends /= No_Project loop - if P = Data.Extends then - return True; - end if; - - Data := Projects.Table (Data.Extends); - end loop; - end; - end if; - - return False; - end Check_Project; - - ------------------ - -- Find_Sources -- - ------------------ - - procedure Find_Sources is - Source_Dir : String_List_Id := Data.Source_Dirs; - Element : String_Element; - Dir : Dir_Type; - Current_Source : String_List_Id := Nil_String; - Source_Recorded : Boolean := False; - - begin - if Current_Verbosity = High then - Write_Line ("Looking for sources:"); - end if; - - -- For each subdirectory - - while Source_Dir /= Nil_String loop - begin - Source_Recorded := False; - Element := String_Elements.Table (Source_Dir); - if Element.Value /= No_Name then - Get_Name_String (Element.Display_Value); - declare - Source_Directory : constant String := - Name_Buffer (1 .. Name_Len) & Directory_Separator; - Dir_Last : constant Natural := - Compute_Directory_Last (Source_Directory); - - begin - if Current_Verbosity = High then - Write_Str ("Source_Dir = "); - Write_Line (Source_Directory); - end if; - - -- We look to every entry in the source directory - - Open (Dir, Source_Directory - (Source_Directory'First .. Dir_Last)); - - -- Canonical_Case_File_Name (Source_Directory); - - loop - Read (Dir, Name_Buffer, Name_Len); - - if Current_Verbosity = High then - Write_Str (" Checking "); - Write_Line (Name_Buffer (1 .. Name_Len)); - end if; - - exit when Name_Len = 0; - - declare - File_Name : constant Name_Id := Name_Find; - Path : constant String := - Normalize_Pathname - (Name => Name_Buffer (1 .. Name_Len), - Directory => Source_Directory - (Source_Directory'First .. Dir_Last), - Resolve_Links => False, - Case_Sensitive => True); - Path_Name : Name_Id; - - begin - if Trusted_Mode or else Is_Regular_File (Path) then - Name_Len := Path'Length; - Name_Buffer (1 .. Name_Len) := Path; - Path_Name := Name_Find; - - -- We attempt to register it as a source. - -- However, there is no error if the file - -- does not contain a valid source. - -- But there is an error if we have a - -- duplicate unit name. - - Record_Source - (File_Name => File_Name, - Path_Name => Path_Name, - Project => Project, - Data => Data, - Location => No_Location, - Current_Source => Current_Source, - Source_Recorded => Source_Recorded, - Trusted_Mode => Trusted_Mode); - end if; - end; - end loop; - - Close (Dir); - end; - end if; - - exception - when Directory_Error => - null; - end; - - if Source_Recorded then - String_Elements.Table (Source_Dir).Flag := True; - end if; - - Source_Dir := Element.Next; - end loop; - - if Current_Verbosity = High then - Write_Line ("end Looking for sources."); - end if; - - -- If we have looked for sources and found none, then - -- it is an error, except if it is an extending project. - -- If a non extending project is not supposed to contain - -- any source, then we never call Find_Sources. - - if Current_Source /= Nil_String then - Data.Sources_Present := True; - - elsif Data.Extends = No_Project then - Error_Msg - (Project, - "there are no Ada sources in this project", - Data.Location); - end if; - end Find_Sources; - --------------------------------------- -- Get_Path_Names_And_Record_Sources -- --------------------------------------- @@ -792,7 +318,8 @@ package body Prj.Nmsc is Source_Recorded : Boolean := False; begin - -- We look in all source directories for this file name + -- We look in all source directories for the file names in the + -- hash table Source_Names while Source_Dir /= Nil_String loop Source_Recorded := False; @@ -837,7 +364,7 @@ package body Prj.Nmsc is -- Register the source if it is an Ada compilation unit.. - Record_Source + Record_Ada_Source (File_Name => Name, Path_Name => Path, Project => Project, @@ -845,7 +372,7 @@ package body Prj.Nmsc is Location => NL.Location, Current_Source => Current_Source, Source_Recorded => Source_Recorded, - Trusted_Mode => Trusted_Mode); + Follow_Links => Follow_Links); end if; end loop; @@ -895,54 +422,13 @@ package body Prj.Nmsc is (Path : String; Location : Source_Ptr) is - File : Prj.Util.Text_File; - Line : String (1 .. 250); - Last : Natural; - Source_Name : Name_Id; - begin - if Current_Verbosity = High then - Write_Str ("Opening """); - Write_Str (Path); - Write_Line ("""."); - end if; - - -- We open the file - - Prj.Util.Open (File, Path); - - if not Prj.Util.Is_Valid (File) then - Error_Msg (Project, "file does not exist", Location); - else - Source_Names.Reset; - - while not Prj.Util.End_Of_File (File) loop - Prj.Util.Get_Line (File, Line, Last); + -- Get the list of sources from the file and put them in hash table + -- Source_Names. - -- If the line is not empty and does not start with "--", - -- then it should contain a file name. However, if the - -- file name does not exist, it may be for another language - -- and we don't fail. + Get_Sources_From_File (Path, Location, Project); - if Last /= 0 - and then (Last = 1 or else Line (1 .. 2) /= "--") - then - Name_Len := Last; - Name_Buffer (1 .. Name_Len) := Line (1 .. Last); - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Source_Name := Name_Find; - Source_Names.Set - (K => Source_Name, - E => - (Name => Source_Name, - Location => Location, - Found => False)); - end if; - end loop; - - Prj.Util.Close (File); - - end if; + -- Look in the source directories to find those sources Get_Path_Names_And_Record_Sources; @@ -991,7 +477,8 @@ package body Prj.Nmsc is if Specs then if not Check_Project - (The_Unit_Data.File_Names (Specification).Project) + (The_Unit_Data.File_Names (Specification).Project, + Project, Extending) then Error_Msg (Project, @@ -1001,7 +488,8 @@ package body Prj.Nmsc is else if not Check_Project - (The_Unit_Data.File_Names (Com.Body_Part).Project) + (The_Unit_Data.File_Names (Com.Body_Part).Project, + Project, Extending) then Error_Msg (Project, @@ -1060,8 +548,8 @@ package body Prj.Nmsc is Check_Naming_Scheme (Data, Project); - Prepare_Naming_Exceptions (Data.Naming.Bodies, Body_Part); - Prepare_Naming_Exceptions (Data.Naming.Specs, Specification); + Prepare_Ada_Naming_Exceptions (Data.Naming.Bodies, Body_Part); + Prepare_Ada_Naming_Exceptions (Data.Naming.Specs, Specification); -- If we have source directories, then find the sources @@ -1086,6 +574,7 @@ package body Prj.Nmsc is (Name_Locally_Removed_Files, Data.Decl.Attributes); + begin pragma Assert (Sources.Kind = List, @@ -1147,7 +636,8 @@ package body Prj.Nmsc is Get_Path_Names_And_Record_Sources; end; - -- No source_files specified. + -- No source_files specified + -- We check Source_List_File has been specified. elsif not Source_List_File.Default then @@ -1178,17 +668,17 @@ package body Prj.Nmsc is else -- Neither Source_Files nor Source_List_File has been - -- specified. - -- Find all the files that satisfy - -- the naming scheme in all the source directories. + -- specified. Find all the files that satisfy the naming + -- scheme in all the source directories. - Find_Sources; + Find_Sources (Project, Data, Lang_Ada, Follow_Links); end if; -- If there are sources that are locally removed, mark them as -- such in the Units table. if not Locally_Removed.Default then + -- Sources can be locally removed only in extending -- project files. @@ -1463,7 +953,8 @@ package body Prj.Nmsc is (Com.Body_Part).Path /= Slash then if Check_Project - (The_Unit_Data.File_Names (Body_Part).Project) + (The_Unit_Data.File_Names (Body_Part).Project, + Project, Extending) then -- There is a body for this unit. -- If there is no spec, we need to check @@ -1515,7 +1006,8 @@ package body Prj.Nmsc is (Com.Specification).Path /= Slash and then Check_Project (The_Unit_Data.File_Names - (Specification).Project) + (Specification).Project, + Project, Extending) then -- The unit is part of the project, it has @@ -1546,6 +1038,7 @@ package body Prj.Nmsc is -- Lib_Auto_Init accordingly. if Lib_Auto_Init.Default then + -- If no attribute Library_Auto_Init is declared, then -- set auto init only if it is supported. @@ -1837,34 +1330,11 @@ package body Prj.Nmsc is -- Put the list of Mains, if any, in the project data - declare - Mains : constant Variable_Value := - Prj.Util.Value_Of (Name_Main, Data.Decl.Attributes); - - begin - Data.Mains := Mains.Values; - - -- If no Mains were specified, and if we are an extending - -- project, inherit the Mains from the project we are extending. - - if Mains.Default then - if Data.Extends /= No_Project then - Data.Mains := Projects.Table (Data.Extends).Mains; - end if; - - -- In a library project file, Main cannot be specified - - elsif Data.Library then - Error_Msg - (Project, - "a library project file cannot have Main specified", - Mains.Location); - end if; - end; + Get_Mains (Project, Data); Projects.Table (Project) := Data; - Free_Naming_Exceptions; + Free_Ada_Naming_Exceptions; end Ada_Check; ------------------- @@ -2008,6 +1478,265 @@ package body Prj.Nmsc is end if; end Check_Ada_Name; + ---------------------- + -- Check_For_Source -- + ---------------------- + + procedure Check_For_Source + (File_Name : Name_Id; + Path_Name : Name_Id; + Project : Project_Id; + Data : in out Project_Data; + Location : Source_Ptr; + Language : Other_Programming_Language; + Suffix : String; + Naming_Exception : Boolean) + is + Name : String := Get_Name_String (File_Name); + Real_Location : Source_Ptr := Location; + + begin + Canonical_Case_File_Name (Name); + + -- A file is a source of a language if Naming_Exception is True (case + -- of naming exceptions) or if its file name ends with the suffix. + + if Naming_Exception or else + (Name'Length > Suffix'Length and then + Name (Name'Last - Suffix'Length + 1 .. Name'Last) = Suffix) + then + if Real_Location = No_Location then + Real_Location := Data.Location; + end if; + + declare + Path : String := Get_Name_String (Path_Name); + + Path_Id : Name_Id; + -- The path name id (in canonical case) + + File_Id : Name_Id; + -- The file name id (in canonical case) + + Obj_Id : Name_Id; + -- The object file name + + Obj_Path_Id : Name_Id; + -- The object path name + + Dep_Id : Name_Id; + -- The dependency file name + + Dep_Path_Id : Name_Id; + -- The dependency path name + + Dot_Pos : Natural := 0; + -- Position of the last dot in Name + + Source : Other_Source; + Source_Id : Other_Source_Id := Data.First_Other_Source; + + begin + Canonical_Case_File_Name (Path); + + -- Get the file name id + + Name_Len := Name'Length; + Name_Buffer (1 .. Name_Len) := Name; + File_Id := Name_Find; + + -- Get the path name id + + Name_Len := Path'Length; + Name_Buffer (1 .. Name_Len) := Path; + Path_Id := Name_Find; + + -- Find the position of the last dot + + for J in reverse Name'Range loop + if Name (J) = '.' then + Dot_Pos := J; + exit; + end if; + end loop; + + if Dot_Pos <= Name'First then + Dot_Pos := Name'Last + 1; + end if; + + -- Compute the object file name + + Get_Name_String (File_Id); + Name_Len := Dot_Pos - Name'First; + + for J in Object_Suffix'Range loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Object_Suffix (J); + end loop; + + Obj_Id := Name_Find; + + -- Compute the object path name + + Get_Name_String (Data.Object_Directory); + + if Name_Buffer (Name_Len) /= Directory_Separator and then + Name_Buffer (Name_Len) /= '/' + then + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Directory_Separator; + end if; + + Add_Str_To_Name_Buffer (Get_Name_String (Obj_Id)); + Obj_Path_Id := Name_Find; + + -- Compute the dependency file name + + Get_Name_String (File_Id); + Name_Len := Dot_Pos - Name'First + 1; + Name_Buffer (Name_Len) := '.'; + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := 'd'; + Dep_Id := Name_Find; + + -- Compute the dependency path name + + Get_Name_String (Data.Object_Directory); + + if Name_Buffer (Name_Len) /= Directory_Separator and then + Name_Buffer (Name_Len) /= '/' + then + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Directory_Separator; + end if; + + Add_Str_To_Name_Buffer (Get_Name_String (Dep_Id)); + Dep_Path_Id := Name_Find; + + -- Check if source is already in the list of source for this + -- project: it may have already been specified as a naming + -- exception for the same language or an other language, or they + -- may be two identical file names in different source + -- directories. + + while Source_Id /= No_Other_Source loop + Source := Other_Sources.Table (Source_Id); + Source_Id := Source.Next; + + if Source.File_Name = File_Id then + -- Two sources of different languages cannot have the same + -- file name. + + if Source.Language /= Language then + Error_Msg_Name_1 := File_Name; + Error_Msg + (Project, + "{ cannot be a source of several languages", + Real_Location); + return; + + -- No problem if a file has already been specified as + -- a naming exception of this language. + + elsif Source.Path_Name = Path_Id then + -- Reset the naming exception flag, if this is not a + -- naming exception. + + if not Naming_Exception then + Other_Sources.Table (Source_Id).Naming_Exception := + False; + end if; + + return; + + -- There are several files with the same names, but the + -- order of the source directories is known (no /**): + -- only the first one encountered is kept, the other ones + -- are ignored. + + elsif Data.Known_Order_Of_Source_Dirs then + return; + + -- But it is an error if the order of the source directories + -- is not known. + + else + Error_Msg_Name_1 := File_Name; + Error_Msg + (Project, + "{ is found in several source directories", + Real_Location); + return; + end if; + + -- Two sources with different file names cannot have the same + -- object file name. + + elsif Source.Object_Name = Obj_Id then + Error_Msg_Name_1 := File_Id; + Error_Msg_Name_2 := Source.File_Name; + Error_Msg_Name_3 := Obj_Id; + Error_Msg + (Project, + "{ and { have the same object file {", + Real_Location); + return; + end if; + end loop; + + if Current_Verbosity = High then + Write_Str (" found "); + Write_Str (Lang_Display_Names (Language).all); + Write_Str (" source """); + Write_Str (Get_Name_String (File_Name)); + Write_Line (""""); + Write_Str (" object path = "); + Write_Line (Get_Name_String (Obj_Path_Id)); + end if; + + -- Create the Other_Source record + Source := + (Language => Language, + File_Name => File_Id, + Path_Name => Path_Id, + Source_TS => File_Stamp (Path_Id), + Object_Name => Obj_Id, + Object_Path => Obj_Path_Id, + Object_TS => File_Stamp (Obj_Path_Id), + Dep_Name => Dep_Id, + Dep_Path => Dep_Path_Id, + Dep_TS => File_Stamp (Dep_Path_Id), + Naming_Exception => Naming_Exception, + Next => No_Other_Source); + + -- And add it to the Other_Sources table + + Other_Sources.Increment_Last; + Other_Sources.Table (Other_Sources.Last) := Source; + + -- There are sources of languages other than Ada in this project + Data.Sources_Present := True; + + -- And there are sources of this language in this project + + Data.Languages (Language) := True; + + -- Add this source to the list of sources of languages other than + -- Ada of the project. + + if Data.First_Other_Source = No_Other_Source then + Data.First_Other_Source := Other_Sources.Last; + + else + Other_Sources.Table (Data.Last_Other_Source).Next := + Other_Sources.Last; + end if; + + Data.Last_Other_Source := Other_Sources.Last; + end; + end if; + end Check_For_Source; + ----------------------------- -- Check_Ada_Naming_Scheme -- ----------------------------- @@ -2143,6 +1872,381 @@ package body Prj.Nmsc is end if; end Check_Ada_Naming_Scheme; + ------------------------- + -- Check_Naming_Scheme -- + ------------------------- + + procedure Check_Naming_Scheme + (Data : in out Project_Data; + Project : Project_Id) + is + Naming_Id : constant Package_Id := + Util.Value_Of (Name_Naming, Data.Decl.Packages); + + Naming : Package_Element; + + procedure Check_Unit_Names (List : Array_Element_Id); + -- Check that a list of unit names contains only valid names. + + ---------------------- + -- Check_Unit_Names -- + ---------------------- + + procedure Check_Unit_Names (List : Array_Element_Id) is + Current : Array_Element_Id := List; + Element : Array_Element; + Unit_Name : Name_Id; + + begin + -- Loop through elements of the string list + + while Current /= No_Array_Element loop + Element := Array_Elements.Table (Current); + + -- Put file name in canonical case + + Get_Name_String (Element.Value.Value); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Element.Value.Value := Name_Find; + + -- Check that it contains a valid unit name + + Get_Name_String (Element.Index); + Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit_Name); + + if Unit_Name = No_Name then + Err_Vars.Error_Msg_Name_1 := Element.Index; + Error_Msg + (Project, + "{ is not a valid unit name.", + Element.Value.Location); + + else + if Current_Verbosity = High then + Write_Str (" Unit ("""); + Write_Str (Get_Name_String (Unit_Name)); + Write_Line (""")"); + end if; + + Element.Index := Unit_Name; + Array_Elements.Table (Current) := Element; + end if; + + Current := Element.Next; + end loop; + end Check_Unit_Names; + + -- Start of processing for Check_Naming_Scheme + + begin + -- If there is a package Naming, we will put in Data.Naming what is in + -- this package Naming. + + if Naming_Id /= No_Package then + Naming := Packages.Table (Naming_Id); + + if Current_Verbosity = High then + Write_Line ("Checking ""Naming"" for Ada."); + end if; + + declare + Bodies : constant Array_Element_Id := + Util.Value_Of (Name_Body, Naming.Decl.Arrays); + + Specs : constant Array_Element_Id := + Util.Value_Of (Name_Spec, Naming.Decl.Arrays); + + begin + if Bodies /= No_Array_Element then + + -- We have elements in the array Body_Part + + if Current_Verbosity = High then + Write_Line ("Found Bodies."); + end if; + + Data.Naming.Bodies := Bodies; + Check_Unit_Names (Bodies); + + else + if Current_Verbosity = High then + Write_Line ("No Bodies."); + end if; + end if; + + if Specs /= No_Array_Element then + + -- We have elements in the array Specs + + if Current_Verbosity = High then + Write_Line ("Found Specs."); + end if; + + Data.Naming.Specs := Specs; + Check_Unit_Names (Specs); + + else + if Current_Verbosity = High then + Write_Line ("No Specs."); + end if; + end if; + end; + + -- We are now checking if variables Dot_Replacement, Casing, + -- Spec_Suffix, Body_Suffix and/or Separate_Suffix + -- exist. + + -- For each variable, if it does not exist, we do nothing, + -- because we already have the default. + + -- Check Dot_Replacement + + declare + Dot_Replacement : constant Variable_Value := + Util.Value_Of + (Name_Dot_Replacement, + Naming.Decl.Attributes); + + begin + pragma Assert (Dot_Replacement.Kind = Single, + "Dot_Replacement is not a single string"); + + if not Dot_Replacement.Default then + Get_Name_String (Dot_Replacement.Value); + + if Name_Len = 0 then + Error_Msg + (Project, + "Dot_Replacement cannot be empty", + Dot_Replacement.Location); + + else + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Data.Naming.Dot_Replacement := Name_Find; + Data.Naming.Dot_Repl_Loc := Dot_Replacement.Location; + end if; + end if; + end; + + if Current_Verbosity = High then + Write_Str (" Dot_Replacement = """); + Write_Str (Get_Name_String (Data.Naming.Dot_Replacement)); + Write_Char ('"'); + Write_Eol; + end if; + + -- Check Casing + + declare + Casing_String : constant Variable_Value := + Util.Value_Of + (Name_Casing, Naming.Decl.Attributes); + + begin + pragma Assert (Casing_String.Kind = Single, + "Casing is not a single string"); + + if not Casing_String.Default then + declare + Casing_Image : constant String := + Get_Name_String (Casing_String.Value); + begin + declare + Casing_Value : constant Casing_Type := + Value (Casing_Image); + begin + -- Ignore Casing on platforms where file names are + -- case-insensitive. + + if not File_Names_Case_Sensitive then + Data.Naming.Casing := All_Lower_Case; + + else + Data.Naming.Casing := Casing_Value; + end if; + end; + + exception + when Constraint_Error => + if Casing_Image'Length = 0 then + Error_Msg + (Project, + "Casing cannot be an empty string", + Casing_String.Location); + + else + Name_Len := Casing_Image'Length; + Name_Buffer (1 .. Name_Len) := Casing_Image; + Err_Vars.Error_Msg_Name_1 := Name_Find; + Error_Msg + (Project, + "{ is not a correct Casing", + Casing_String.Location); + end if; + end; + end if; + end; + + if Current_Verbosity = High then + Write_Str (" Casing = "); + Write_Str (Image (Data.Naming.Casing)); + Write_Char ('.'); + Write_Eol; + end if; + + -- Check Spec_Suffix + + declare + Ada_Spec_Suffix : constant Variable_Value := + Prj.Util.Value_Of + (Index => Name_Ada, + In_Array => Data.Naming.Spec_Suffix); + + begin + if Ada_Spec_Suffix.Kind = Single + and then Get_Name_String (Ada_Spec_Suffix.Value) /= "" + then + Get_Name_String (Ada_Spec_Suffix.Value); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Data.Naming.Current_Spec_Suffix := Name_Find; + Data.Naming.Spec_Suffix_Loc := Ada_Spec_Suffix.Location; + + else + Data.Naming.Current_Spec_Suffix := Default_Ada_Spec_Suffix; + end if; + end; + + if Current_Verbosity = High then + Write_Str (" Spec_Suffix = """); + Write_Str (Get_Name_String (Data.Naming.Current_Spec_Suffix)); + Write_Char ('"'); + Write_Eol; + end if; + + -- Check Body_Suffix + + declare + Ada_Body_Suffix : constant Variable_Value := + Prj.Util.Value_Of + (Index => Name_Ada, + In_Array => Data.Naming.Body_Suffix); + + begin + if Ada_Body_Suffix.Kind = Single + and then Get_Name_String (Ada_Body_Suffix.Value) /= "" + then + Get_Name_String (Ada_Body_Suffix.Value); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Data.Naming.Current_Body_Suffix := Name_Find; + Data.Naming.Body_Suffix_Loc := Ada_Body_Suffix.Location; + + else + Data.Naming.Current_Body_Suffix := Default_Ada_Body_Suffix; + end if; + end; + + if Current_Verbosity = High then + Write_Str (" Body_Suffix = """); + Write_Str (Get_Name_String (Data.Naming.Current_Body_Suffix)); + Write_Char ('"'); + Write_Eol; + end if; + + -- Check Separate_Suffix + + declare + Ada_Sep_Suffix : constant Variable_Value := + Prj.Util.Value_Of + (Variable_Name => Name_Separate_Suffix, + In_Variables => Naming.Decl.Attributes); + + begin + if Ada_Sep_Suffix.Default then + Data.Naming.Separate_Suffix := + Data.Naming.Current_Body_Suffix; + + else + Get_Name_String (Ada_Sep_Suffix.Value); + + if Name_Len = 0 then + Error_Msg + (Project, + "Separate_Suffix cannot be empty", + Ada_Sep_Suffix.Location); + + else + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Data.Naming.Separate_Suffix := Name_Find; + Data.Naming.Sep_Suffix_Loc := Ada_Sep_Suffix.Location; + end if; + end if; + end; + + if Current_Verbosity = High then + Write_Str (" Separate_Suffix = """); + Write_Str (Get_Name_String (Data.Naming.Separate_Suffix)); + Write_Char ('"'); + Write_Eol; + end if; + + -- Check if Data.Naming is valid + + Check_Ada_Naming_Scheme (Project, Data.Naming); + + else + Data.Naming.Current_Spec_Suffix := Default_Ada_Spec_Suffix; + Data.Naming.Current_Body_Suffix := Default_Ada_Body_Suffix; + Data.Naming.Separate_Suffix := Default_Ada_Body_Suffix; + end if; + end Check_Naming_Scheme; + + ------------------- + -- Check_Project -- + ------------------- + + function Check_Project + (P : Project_Id; + Root_Project : Project_Id; + Extending : Boolean) return Boolean + is + begin + if P = Root_Project then + return True; + + elsif Extending then + declare + Data : Project_Data := Projects.Table (Root_Project); + + begin + while Data.Extends /= No_Project loop + if P = Data.Extends then + return True; + end if; + + Data := Projects.Table (Data.Extends); + end loop; + end; + end if; + + return False; + end Check_Project; + + ---------------------------- + -- Compute_Directory_Last -- + ---------------------------- + + function Compute_Directory_Last (Dir : String) return Natural is + begin + if Dir'Length > 1 + and then (Dir (Dir'Last - 1) = Directory_Separator + or else Dir (Dir'Last - 1) = '/') + then + return Dir'Last - 1; + else + return Dir'Last; + end if; + end Compute_Directory_Last; + --------------- -- Error_Msg -- --------------- @@ -2237,6 +2341,249 @@ package body Prj.Nmsc is Error_Report (Error_Buffer (1 .. Error_Last), Project); end Error_Msg; + ------------------ + -- Find_Sources -- + ------------------ + + procedure Find_Sources + (Project : Project_Id; + Data : in out Project_Data; + For_Language : Programming_Language; + Follow_Links : Boolean := False) + is + Source_Dir : String_List_Id := Data.Source_Dirs; + Element : String_Element; + Dir : Dir_Type; + Current_Source : String_List_Id := Nil_String; + Source_Recorded : Boolean := False; + + begin + if Current_Verbosity = High then + Write_Line ("Looking for sources:"); + end if; + + -- For each subdirectory + + while Source_Dir /= Nil_String loop + begin + Source_Recorded := False; + Element := String_Elements.Table (Source_Dir); + if Element.Value /= No_Name then + Get_Name_String (Element.Display_Value); + + declare + Source_Directory : constant String := + Name_Buffer (1 .. Name_Len) & Directory_Separator; + Dir_Last : constant Natural := + Compute_Directory_Last (Source_Directory); + + begin + if Current_Verbosity = High then + Write_Str ("Source_Dir = "); + Write_Line (Source_Directory); + end if; + + -- We look to every entry in the source directory + + Open (Dir, Source_Directory + (Source_Directory'First .. Dir_Last)); + + loop + Read (Dir, Name_Buffer, Name_Len); + + if Current_Verbosity = High then + Write_Str (" Checking "); + Write_Line (Name_Buffer (1 .. Name_Len)); + end if; + + exit when Name_Len = 0; + + declare + File_Name : constant Name_Id := Name_Find; + Path : constant String := + Normalize_Pathname + (Name => Name_Buffer (1 .. Name_Len), + Directory => Source_Directory + (Source_Directory'First .. Dir_Last), + Resolve_Links => Follow_Links, + Case_Sensitive => True); + Path_Name : Name_Id; + + begin + Name_Len := Path'Length; + Name_Buffer (1 .. Name_Len) := Path; + Path_Name := Name_Find; + + if For_Language = Lang_Ada then + -- We attempt to register it as a source. + -- However, there is no error if the file + -- does not contain a valid source. + -- But there is an error if we have a + -- duplicate unit name. + + Record_Ada_Source + (File_Name => File_Name, + Path_Name => Path_Name, + Project => Project, + Data => Data, + Location => No_Location, + Current_Source => Current_Source, + Source_Recorded => Source_Recorded, + Follow_Links => Follow_Links); + + else + Check_For_Source + (File_Name => File_Name, + Path_Name => Path_Name, + Project => Project, + Data => Data, + Location => No_Location, + Language => For_Language, + Suffix => + Get_Name_String + (Data.Impl_Suffixes (For_Language)), + Naming_Exception => False); + end if; + end; + end loop; + + Close (Dir); + end; + end if; + + exception + when Directory_Error => + null; + end; + + if Source_Recorded then + String_Elements.Table (Source_Dir).Flag := True; + end if; + + Source_Dir := Element.Next; + end loop; + + if Current_Verbosity = High then + Write_Line ("end Looking for sources."); + end if; + + if For_Language = Lang_Ada then + -- If we have looked for sources and found none, then + -- it is an error, except if it is an extending project. + -- If a non extending project is not supposed to contain + -- any source, then we never call Find_Sources. + + if Current_Source /= Nil_String then + Data.Sources_Present := True; + + elsif Data.Extends = No_Project then + Error_Msg + (Project, + "there are no Ada sources in this project", + Data.Location); + end if; + end if; + end Find_Sources; + + -------------------------------- + -- Free_Ada_Naming_Exceptions -- + -------------------------------- + + procedure Free_Ada_Naming_Exceptions is + begin + Ada_Naming_Exceptions.Reset; + Reverse_Ada_Naming_Exceptions.Reset; + end Free_Ada_Naming_Exceptions; + + --------------- + -- Get_Mains -- + --------------- + + procedure Get_Mains (Project : Project_Id; Data : in out Project_Data) is + Mains : constant Variable_Value := + Prj.Util.Value_Of (Name_Main, Data.Decl.Attributes); + + begin + Data.Mains := Mains.Values; + + -- If no Mains were specified, and if we are an extending + -- project, inherit the Mains from the project we are extending. + + if Mains.Default then + if Data.Extends /= No_Project then + Data.Mains := Projects.Table (Data.Extends).Mains; + end if; + + -- In a library project file, Main cannot be specified + + elsif Data.Library then + Error_Msg + (Project, + "a library project file cannot have Main specified", + Mains.Location); + end if; + end Get_Mains; + + --------------------------- + -- Get_Sources_From_File -- + --------------------------- + + procedure Get_Sources_From_File + (Path : String; + Location : Source_Ptr; + Project : Project_Id) + is + File : Prj.Util.Text_File; + Line : String (1 .. 250); + Last : Natural; + Source_Name : Name_Id; + + begin + Source_Names.Reset; + + if Current_Verbosity = High then + Write_Str ("Opening """); + Write_Str (Path); + Write_Line ("""."); + end if; + + -- Open the file + + Prj.Util.Open (File, Path); + + if not Prj.Util.Is_Valid (File) then + Error_Msg (Project, "file does not exist", Location); + else + -- Read the lines one by one + + while not Prj.Util.End_Of_File (File) loop + Prj.Util.Get_Line (File, Line, Last); + + -- A non empty, non comment line should contain a file name + + if Last /= 0 + and then (Last = 1 or else Line (1 .. 2) /= "--") + then + -- ??? we should check that there is no directory information + + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := Line (1 .. Last); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Source_Name := Name_Find; + Source_Names.Set + (K => Source_Name, + E => + (Name => Source_Name, + Location => Location, + Found => False)); + end if; + end loop; + + Prj.Util.Close (File); + + end if; + end Get_Sources_From_File; + -------------- -- Get_Unit -- -------------- @@ -2258,7 +2605,7 @@ package body Prj.Nmsc is --------------------- function Check_Exception (Canonical : Name_Id) return Boolean is - Info : Unit_Info := Naming_Exceptions.Get (Canonical); + Info : Unit_Info := Ada_Naming_Exceptions.Get (Canonical); VMS_Name : Name_Id; begin @@ -2272,7 +2619,7 @@ package body Prj.Nmsc is VMS_Name := Name_Find; end if; - Info := Naming_Exceptions.Get (VMS_Name); + Info := Ada_Naming_Exceptions.Get (VMS_Name); end if; if Info = No_Unit then @@ -2514,6 +2861,15 @@ package body Prj.Nmsc is end; end Get_Unit; + ---------- + -- Hash -- + ---------- + + function Hash (Unit : Unit_Info) return Header_Num is + begin + return Header_Num (Unit.Unit mod 2048); + end Hash; + ----------------------- -- Is_Illegal_Suffix -- ----------------------- @@ -3609,6 +3965,330 @@ package body Prj.Nmsc is end if; end Locate_Directory; + --------------------------- + -- Other_Languages_Check -- + --------------------------- + + procedure Other_Languages_Check + (Project : Project_Id; + Report_Error : Put_Line_Access) is + + Data : Project_Data; + + Languages : Variable_Value := Nil_Variable_Value; + + begin + Language_Independent_Check (Project, Report_Error); + + Error_Report := Report_Error; + + Data := Projects.Table (Project); + Languages := Prj.Util.Value_Of (Name_Languages, Data.Decl.Attributes); + + Data.Sources_Present := Data.Source_Dirs /= Nil_String; + + if Data.Sources_Present then + -- Check if languages other than Ada are specified in this project + + if Languages.Default then + -- Attribute Languages is not specified. So, it defaults to + -- a project of language Ada only. + + Data.Languages (Lang_Ada) := True; + + -- No sources of languages other than Ada + + Data.Sources_Present := False; + + else + declare + Current : String_List_Id := Languages.Values; + Element : String_Element; + OK : Boolean := False; + begin + -- Assumethat there is no language other than Ada specified. + -- If in fact there is at least one, we will set back + -- Sources_Present to True. + + Data.Sources_Present := False; + + -- Look through all the languages specified in attribute + -- Languages, if any + + while Current /= Nil_String loop + Element := String_Elements.Table (Current); + Get_Name_String (Element.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + OK := False; + + -- Check if it is a known language + + Lang_Loop : for Lang in Programming_Language loop + if + Name_Buffer (1 .. Name_Len) = Lang_Names (Lang).all + then + -- Yes, this is a known language + + OK := True; + + -- Indicate the presence of this language + Data.Languages (Lang) := True; + + -- If it is a language other than Ada, indicate that + -- there should be some sources of a language other + -- than Ada. + + if Lang /= Lang_Ada then + Data.Sources_Present := True; + end if; + + exit Lang_Loop; + end if; + end loop Lang_Loop; + + -- We don't support this language: report an error + + if not OK then + Error_Msg_Name_1 := Element.Value; + Error_Msg + (Project, + "unknown programming language {", + Element.Location); + end if; + + Current := Element.Next; + end loop; + end; + end if; + end if; + + -- If there may be some sources, look for them + + if Data.Sources_Present then + -- Set Source_Present to False. It will be set back to True whenever + -- a source is found. + + Data.Sources_Present := False; + + for Lang in Other_Programming_Language loop + -- For each language (other than Ada) in the project file + + if Data.Languages (Lang) then + -- Reset the indication that there are sources of this + -- language. It will be set back to True whenever we find a + -- source of the language. + + Data.Languages (Lang) := False; + + -- First, get the source suffix for the language + + Data.Impl_Suffixes (Lang) := Suffix_For (Lang, Data.Naming); + + -- Then, deal with the naming exceptions, if any + + Source_Names.Reset; + + declare + Naming_Exceptions : constant Variable_Value := + Value_Of + (Index => Lang_Name_Ids (Lang), + In_Array => Data.Naming.Implementation_Exceptions); + Element_Id : String_List_Id; + Element : String_Element; + File_Id : Name_Id; + Source_Found : Boolean := False; + begin + -- If there are naming exceptions, look through them one + -- by one. + + if Naming_Exceptions /= Nil_Variable_Value then + Element_Id := Naming_Exceptions.Values; + + while Element_Id /= Nil_String loop + Element := String_Elements.Table (Element_Id); + Get_Name_String (Element.Value); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + File_Id := Name_Find; + + -- Put each naming exception in the Source_Names + -- hash table, but if there are repetition, don't + -- bother after the first instance. + + if Source_Names.Get (File_Id) = No_Name_Location then + Source_Found := True; + Source_Names.Set + (File_Id, + (Name => File_Id, + Location => Element.Location, + Found => False)); + end if; + + Element_Id := Element.Next; + end loop; + + -- If there is at least one naming exception, record + -- those that are found in the source directories. + + if Source_Found then + Record_Other_Sources + (Project => Project, + Data => Data, + Language => Lang, + Naming_Exceptions => True); + end if; + + end if; + end; + + -- Now, check if a list of sources is declared either through + -- a string list (attribute Source_Files) or a text file + -- (attribute Source_List_File). + -- If a source list is declared, we will consider only those + -- naming exceptions that are on the list. + + declare + Sources : constant Variable_Value := + Util.Value_Of + (Name_Source_Files, + Data.Decl.Attributes); + + Source_List_File : constant Variable_Value := + Util.Value_Of + (Name_Source_List_File, + Data.Decl.Attributes); + + begin + pragma Assert + (Sources.Kind = List, + "Source_Files is not a list"); + + pragma Assert + (Source_List_File.Kind = Single, + "Source_List_File is not a single string"); + + if not Sources.Default then + if not Source_List_File.Default then + Error_Msg + (Project, + "?both variables source_files and " & + "source_list_file are present", + Source_List_File.Location); + end if; + + -- Sources is a list of file names + + declare + Current : String_List_Id := Sources.Values; + Element : String_Element; + Location : Source_Ptr; + Name : Name_Id; + + begin + Source_Names.Reset; + + -- Put all the sources in the Source_Names hash + -- table. + + while Current /= Nil_String loop + Element := String_Elements.Table (Current); + Get_Name_String (Element.Value); + Canonical_Case_File_Name + (Name_Buffer (1 .. Name_Len)); + Name := Name_Find; + + -- If the element has no location, then use the + -- location of Sources to report possible errors. + + if Element.Location = No_Location then + Location := Sources.Location; + + else + Location := Element.Location; + end if; + + Source_Names.Set + (K => Name, + E => + (Name => Name, + Location => Location, + Found => False)); + + Current := Element.Next; + end loop; + + -- And look for their directories + + Record_Other_Sources + (Project => Project, + Data => Data, + Language => Lang, + Naming_Exceptions => False); + end; + + -- No source_files specified. + -- We check if Source_List_File has been specified. + + elsif not Source_List_File.Default then + + -- Source_List_File is the name of the file + -- that contains the source file names + + declare + Source_File_Path_Name : constant String := + Path_Name_Of + (Source_List_File.Value, + Data.Directory); + + begin + if Source_File_Path_Name'Length = 0 then + Err_Vars.Error_Msg_Name_1 := Source_List_File.Value; + Error_Msg + (Project, + "file with sources { does not exist", + Source_List_File.Location); + + else + -- Read the file, putting each source in the + -- Source_Names hash table. + + Get_Sources_From_File + (Source_File_Path_Name, + Source_List_File.Location, + Project); + + -- And look for their directories. + + Record_Other_Sources + (Project => Project, + Data => Data, + Language => Lang, + Naming_Exceptions => False); + end if; + end; + + else + -- Neither Source_Files nor Source_List_File has been + -- specified. Find all the files that satisfy + -- the naming scheme in all the source directories. + -- All the naming exceptions that effectively exist are + -- also part of the source of this language. + + Find_Sources (Project, Data, Lang); + end if; + + end; + end if; + end loop; + end if; + + -- Finally, get the mains, if any + + Get_Mains (Project, Data); + + Projects.Table (Project) := Data; + + end Other_Languages_Check; + ------------------ -- Path_Name_Of -- ------------------ @@ -3634,6 +4314,36 @@ package body Prj.Nmsc is end if; end Path_Name_Of; + ------------------------------- + -- Prepare_Ada_Naming_Exceptions -- + ------------------------------- + + procedure Prepare_Ada_Naming_Exceptions + (List : Array_Element_Id; + Kind : Spec_Or_Body) + is + Current : Array_Element_Id := List; + Element : Array_Element; + + begin + -- Traverse the list + + while Current /= No_Array_Element loop + Element := Array_Elements.Table (Current); + + if Element.Index /= No_Name then + Ada_Naming_Exceptions.Set + (Element.Value.Value, + (Kind => Kind, Unit => Element.Index)); + Reverse_Ada_Naming_Exceptions.Set + ((Kind => Kind, Unit => Element.Index), + Element.Value.Value); + end if; + + Current := Element.Next; + end loop; + end Prepare_Ada_Naming_Exceptions; + --------------------- -- Project_Extends -- --------------------- @@ -3656,11 +4366,11 @@ package body Prj.Nmsc is end loop; end Project_Extends; - ------------------- - -- Record_Source -- - ------------------- + ----------------------- + -- Record_Ada_Source -- + ----------------------- - procedure Record_Source + procedure Record_Ada_Source (File_Name : Name_Id; Path_Name : Name_Id; Project : Project_Id; @@ -3668,7 +4378,7 @@ package body Prj.Nmsc is Location : Source_Ptr; Current_Source : in out String_List_Id; Source_Recorded : in out Boolean; - Trusted_Mode : Boolean) + Follow_Links : Boolean) is Canonical_File_Name : Name_Id; Canonical_Path_Name : Name_Id; @@ -3691,7 +4401,7 @@ package body Prj.Nmsc is Canonical_Path : constant String := Normalize_Pathname (Get_Name_String (Path_Name), - Resolve_Links => not Trusted_Mode, + Resolve_Links => Follow_Links, Case_Sensitive => False); begin Name_Len := 0; @@ -3722,7 +4432,7 @@ package body Prj.Nmsc is if not Needs_Pragma then Except_Name := - Reverse_Naming_Exceptions.Get ((Unit_Kind, Unit_Name)); + Reverse_Ada_Naming_Exceptions.Get ((Unit_Kind, Unit_Name)); if Except_Name /= No_Name then if Current_Verbosity = High then @@ -3881,7 +4591,180 @@ package body Prj.Nmsc is end if; end; end if; - end Record_Source; + end Record_Ada_Source; + + -------------------------- + -- Record_Other_Sources -- + -------------------------- + + procedure Record_Other_Sources + (Project : Project_Id; + Data : in out Project_Data; + Language : Programming_Language; + Naming_Exceptions : Boolean) + is + Source_Dir : String_List_Id := Data.Source_Dirs; + Element : String_Element; + Path : Name_Id; + + Dir : Dir_Type; + Canonical_Name : Name_Id; + Name_Str : String (1 .. 1_024); + Last : Natural := 0; + NL : Name_Location; + + First_Error : Boolean := True; + + Suffix : constant String := + Get_Name_String (Data.Impl_Suffixes (Language)); + + begin + while Source_Dir /= Nil_String loop + Element := String_Elements.Table (Source_Dir); + + declare + Dir_Path : constant String := Get_Name_String (Element.Value); + begin + if Current_Verbosity = High then + Write_Str ("checking directory """); + Write_Str (Dir_Path); + Write_Str (""" for "); + + if Naming_Exceptions then + Write_Str ("naming exceptions"); + + else + Write_Str ("sources"); + end if; + + Write_Str (" of Language "); + Write_Line (Lang_Display_Names (Language).all); + end if; + + Open (Dir, Dir_Path); + + loop + Read (Dir, Name_Str, Last); + exit when Last = 0; + + if Is_Regular_File + (Dir_Path & Directory_Separator & Name_Str (1 .. Last)) + then + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last); + Canonical_Name := Name_Find; + NL := Source_Names.Get (Canonical_Name); + + if NL /= No_Name_Location then + if NL.Found then + if not Data.Known_Order_Of_Source_Dirs then + Error_Msg_Name_1 := Canonical_Name; + Error_Msg + (Project, + "{ is found in several source directories", + NL.Location); + end if; + + else + NL.Found := True; + Source_Names.Set (Canonical_Name, NL); + Name_Len := Dir_Path'Length; + Name_Buffer (1 .. Name_Len) := Dir_Path; + Add_Char_To_Name_Buffer (Directory_Separator); + Add_Str_To_Name_Buffer (Name_Str (1 .. Last)); + Path := Name_Find; + + Check_For_Source + (File_Name => Canonical_Name, + Path_Name => Path, + Project => Project, + Data => Data, + Location => NL.Location, + Language => Language, + Suffix => Suffix, + Naming_Exception => Naming_Exceptions); + end if; + end if; + end if; + end loop; + + Close (Dir); + end; + + Source_Dir := Element.Next; + end loop; + + if not Naming_Exceptions then + + NL := Source_Names.Get_First; + + -- It is an error if a source file name in a source list or + -- in a source list file is not found. + + while NL /= No_Name_Location loop + if not NL.Found then + Err_Vars.Error_Msg_Name_1 := NL.Name; + + if First_Error then + Error_Msg + (Project, + "source file { cannot be found", + NL.Location); + First_Error := False; + + else + Error_Msg + (Project, + "\source file { cannot be found", + NL.Location); + end if; + end if; + + NL := Source_Names.Get_Next; + end loop; + + -- Any naming exception of this language that is not in a list + -- of sources must be removed. + + declare + Source_Id : Other_Source_Id := Data.First_Other_Source; + Prev_Id : Other_Source_Id := No_Other_Source; + Source : Other_Source; + begin + while Source_Id /= No_Other_Source loop + Source := Other_Sources.Table (Source_Id); + + if Source.Language = Language + and then Source.Naming_Exception + then + if Current_Verbosity = High then + Write_Str ("Naming exception """); + Write_Str (Get_Name_String (Source.File_Name)); + Write_Str (""" is not in the list of sources,"); + Write_Line (" so it is removed."); + end if; + + if Prev_Id = No_Other_Source then + Data.First_Other_Source := Source.Next; + + else + Other_Sources.Table (Prev_Id).Next := Source.Next; + end if; + + Source_Id := Source.Next; + + if Source_Id = No_Other_Source then + Data.Last_Other_Source := Prev_Id; + end if; + + else + Prev_Id := Source_Id; + Source_Id := Source.Next; + end if; + end loop; + end; + end if; + end Record_Other_Sources; ---------------------- -- Show_Source_Dirs -- @@ -3904,4 +4787,34 @@ package body Prj.Nmsc is Write_Line ("end Source_Dirs."); end Show_Source_Dirs; + ---------------- + -- Suffix_For -- + ---------------- + + function Suffix_For + (Language : Programming_Language; + Naming : Naming_Data) return Name_Id + is + Suffix : constant Variable_Value := + Value_Of + (Index => Lang_Name_Ids (Language), + In_Array => Naming.Body_Suffix); + begin + -- If no suffix for this language is found in package Naming, use the + -- default. + + if Suffix = Nil_Variable_Value then + Name_Len := 0; + Add_Str_To_Name_Buffer (Lang_Suffixes (Language).all); + + -- Otherwise use the one specified + + else + Get_Name_String (Suffix.Value); + end if; + + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + return Name_Find; + end Suffix_For; + end Prj.Nmsc; diff --git a/gcc/ada/prj-nmsc.ads b/gcc/ada/prj-nmsc.ads index 5d13071..9202ad3 100644 --- a/gcc/ada/prj-nmsc.ads +++ b/gcc/ada/prj-nmsc.ads @@ -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. diff --git a/gcc/ada/prj-pars.adb b/gcc/ada/prj-pars.adb index 19a560d..bf26688 100644 --- a/gcc/ada/prj-pars.adb +++ b/gcc/ada/prj-pars.adb @@ -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 diff --git a/gcc/ada/prj-pars.ads b/gcc/ada/prj-pars.ads index 4f157ef..be23e4b 100644 --- a/gcc/ada/prj-pars.ads +++ b/gcc/ada/prj-pars.ads @@ -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 diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 1258e24..170da25 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -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; diff --git a/gcc/ada/prj-proc.ads b/gcc/ada/prj-proc.ads index 2d0cf44..ca55a51 100644 --- a/gcc/ada/prj-proc.ads +++ b/gcc/ada/prj-proc.ads @@ -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; diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb index 15f893a..4081e11 100644 --- a/gcc/ada/prj-util.adb +++ b/gcc/ada/prj-util.adb @@ -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; diff --git a/gcc/ada/prj-util.ads b/gcc/ada/prj-util.ads index 57067e2..c40b294 100644 --- a/gcc/ada/prj-util.ads +++ b/gcc/ada/prj-util.ads @@ -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. diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 0f09236..b71b7db 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -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; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 3f9033c..b9965bc 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -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. diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 04ef5b9..aa51054 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -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, diff --git a/gcc/ada/s-auxdec.adb b/gcc/ada/s-auxdec.adb index 51d6ac5..f2f71b2 100644 --- a/gcc/ada/s-auxdec.adb +++ b/gcc/ada/s-auxdec.adb @@ -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; diff --git a/gcc/ada/s-carsi8.adb b/gcc/ada/s-carsi8.adb index ebc86e7..70fc2d4 100644 --- a/gcc/ada/s-carsi8.adb +++ b/gcc/ada/s-carsi8.adb @@ -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 diff --git a/gcc/ada/s-carsi8.ads b/gcc/ada/s-carsi8.ads index 64a5205..f810dd6 100644 --- a/gcc/ada/s-carsi8.ads +++ b/gcc/ada/s-carsi8.ads @@ -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. diff --git a/gcc/ada/s-carun8.adb b/gcc/ada/s-carun8.adb index 26a314e..4a23109 100644 --- a/gcc/ada/s-carun8.adb +++ b/gcc/ada/s-carun8.adb @@ -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 diff --git a/gcc/ada/s-carun8.ads b/gcc/ada/s-carun8.ads index e6ff79a..1e3de47 100644 --- a/gcc/ada/s-carun8.ads +++ b/gcc/ada/s-carun8.ads @@ -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. diff --git a/gcc/ada/s-casi16.adb b/gcc/ada/s-casi16.adb index dc417e3..596b076 100644 --- a/gcc/ada/s-casi16.adb +++ b/gcc/ada/s-casi16.adb @@ -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 diff --git a/gcc/ada/s-casi16.ads b/gcc/ada/s-casi16.ads index 234b360..d3c226f 100644 --- a/gcc/ada/s-casi16.ads +++ b/gcc/ada/s-casi16.ads @@ -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 diff --git a/gcc/ada/s-casi32.adb b/gcc/ada/s-casi32.adb index 2f28018..cee5a57 100644 --- a/gcc/ada/s-casi32.adb +++ b/gcc/ada/s-casi32.adb @@ -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 diff --git a/gcc/ada/s-casi32.ads b/gcc/ada/s-casi32.ads index c97911d..de35add 100644 --- a/gcc/ada/s-casi32.ads +++ b/gcc/ada/s-casi32.ads @@ -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- -- diff --git a/gcc/ada/s-casi64.adb b/gcc/ada/s-casi64.adb index 5d6cea9..9d14135 100644 --- a/gcc/ada/s-casi64.adb +++ b/gcc/ada/s-casi64.adb @@ -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 diff --git a/gcc/ada/s-casi64.ads b/gcc/ada/s-casi64.ads index bc4d3b2..0215bad 100644 --- a/gcc/ada/s-casi64.ads +++ b/gcc/ada/s-casi64.ads @@ -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 diff --git a/gcc/ada/s-caun16.adb b/gcc/ada/s-caun16.adb index c9d1ffa..779b097 100644 --- a/gcc/ada/s-caun16.adb +++ b/gcc/ada/s-caun16.adb @@ -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 diff --git a/gcc/ada/s-caun16.ads b/gcc/ada/s-caun16.ads index e395c37..5bf4e35 100644 --- a/gcc/ada/s-caun16.ads +++ b/gcc/ada/s-caun16.ads @@ -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 diff --git a/gcc/ada/s-caun32.adb b/gcc/ada/s-caun32.adb index 830312f..8672464 100644 --- a/gcc/ada/s-caun32.adb +++ b/gcc/ada/s-caun32.adb @@ -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 diff --git a/gcc/ada/s-caun32.ads b/gcc/ada/s-caun32.ads index 0ca7d0c..9c6fb8d 100644 --- a/gcc/ada/s-caun32.ads +++ b/gcc/ada/s-caun32.ads @@ -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 diff --git a/gcc/ada/s-caun64.adb b/gcc/ada/s-caun64.adb index c05a47f..6e3c5ed 100644 --- a/gcc/ada/s-caun64.adb +++ b/gcc/ada/s-caun64.adb @@ -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 diff --git a/gcc/ada/s-caun64.ads b/gcc/ada/s-caun64.ads index b0446d6..c842190 100644 --- a/gcc/ada/s-caun64.ads +++ b/gcc/ada/s-caun64.ads @@ -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 diff --git a/gcc/ada/s-geveop.adb b/gcc/ada/s-geveop.adb index 1820bdf..13233d0 100644 --- a/gcc/ada/s-geveop.adb +++ b/gcc/ada/s-geveop.adb @@ -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; diff --git a/gcc/ada/s-parint.adb b/gcc/ada/s-parint.adb index 0f0484d..1174d75 100644 --- a/gcc/ada/s-parint.adb +++ b/gcc/ada/s-parint.adb @@ -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 -- ------------------------------------- diff --git a/gcc/ada/s-parint.ads b/gcc/ada/s-parint.ads index d37325e..287b2b3 100644 --- a/gcc/ada/s-parint.ads +++ b/gcc/ada/s-parint.ads @@ -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); diff --git a/gcc/ada/s-stalib.ads b/gcc/ada/s-stalib.ads index 84bf0b9..c2865a9 100644 --- a/gcc/ada/s-stalib.ads +++ b/gcc/ada/s-stalib.ads @@ -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 diff --git a/gcc/ada/s-stoele.ads b/gcc/ada/s-stoele.ads index 5358138..1799a7e 100644 --- a/gcc/ada/s-stoele.ads +++ b/gcc/ada/s-stoele.ads @@ -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; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index cf0ba5e..cf6cfac 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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)) diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 3cae7d3..fb233a2 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -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 diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 2b958a8..cce3e09 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index bd2a07f..4fe8cdb 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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); - - -- 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. + -- The declaration uses the bounds of an existing object, + -- and therefore needs no constraint checks. - 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. diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 9a61938..379c74c 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -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)); diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index efaf5a1..62db6fd 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -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); diff --git a/gcc/ada/sem_dist.ads b/gcc/ada/sem_dist.ads index 1ce18bf..efadbef 100644 --- a/gcc/ada/sem_dist.ads +++ b/gcc/ada/sem_dist.ads @@ -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 diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb index 3f99d82..3117549 100644 --- a/gcc/ada/sem_elim.adb +++ b/gcc/ada/sem_elim.adb @@ -29,12 +29,12 @@ with Einfo; use Einfo; with Errout; use Errout; with Namet; use Namet; with Nlists; use Nlists; +with Sinput; use Sinput; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Table; -with Uintp; use Uintp; with GNAT.HTable; use GNAT.HTable; package body Sem_Elim is @@ -83,8 +83,9 @@ package body Sem_Elim is Result_Type : Name_Id; -- Result type name if Result_Types parameter present, No_Name if not - Homonym_Number : Uint; - -- Homonyn number if Homonym_Number parameter present, No_Uint if not. + Source_Location : Name_Id; + -- String describing the source location of subprogram defining name if + -- Source_Location parameter present, No_Name if not Hash_Link : Access_Elim_Data; -- Link for hash table use @@ -229,8 +230,6 @@ package body Sem_Elim is Elmt : Access_Elim_Data; Scop : Entity_Id; Form : Entity_Id; - Ctr : Nat; - Ent : Entity_Id; function Original_Chars (S : Entity_Id) return Name_Id; -- If the candidate subprogram is a protected operation of a single @@ -360,22 +359,200 @@ package body Sem_Elim is elsif Ekind (E) = E_Function or else Ekind (E) = E_Procedure then - -- If Homonym_Number present, then see if it matches + -- If Source_Location present, then see if it matches + + if Elmt.Source_Location /= No_Name then + Get_Name_String (Elmt.Source_Location); + + declare + Sloc_Trace : constant String := + Name_Buffer (1 .. Name_Len); + + Idx : Natural := Sloc_Trace'First; + -- Index in Sloc_Trace, if equals to 0, then we have + -- completely traversed Sloc_Trace + + Last : constant Natural := Sloc_Trace'Last; + + P : Source_Ptr; + Sindex : Source_File_Index; + + function File_Mame_Match return Boolean; + -- This function is supposed to be called when Idx points + -- to the beginning of the new file name, and Name_Buffer + -- is set to contain the name of the proper source file + -- from the chain corresponding to the Sloc of E. First + -- it checks that these two files have the same name. If + -- this check is successful, moves Idx to point to the + -- beginning of the column number. + + function Line_Num_Match return Boolean; + -- This function is supposed to be called when Idx points + -- to the beginning of the column number, and P is + -- set to point to the proper Sloc the chain + -- corresponding to the Sloc of E. First it checks that + -- the line number Idx points on and the line number + -- corresponding to P are the same. If this check is + -- successful, moves Idx to point to the beginning of + -- the next file name in Sloc_Trace. If there is no file + -- name any more, Idx is set to 0. + + function Different_Trace_Lengths return Boolean; + -- From Idx and P, defines if there are in both traces + -- more element(s) in the instantiation chains. Returns + -- False if one trace contains more element(s), but + -- another does not. If both traces contains more + -- elements (that is, the function returns False), moves + -- P ahead in the chain corresponding to E, recomputes + -- Sindex and sets the name of the corresponding file in + -- Name_Buffer + + function Skip_Spaces return Natural; + -- If Sloc_Trace (Idx) is not space character, returns + -- Idx. Otherwise returns the index of the nearest + -- non-space character in Sloc_Trace to the right of + -- Idx. Returns 0 if there is no such character. + + function Different_Trace_Lengths return Boolean is + begin + P := Instantiation (Sindex); + + if (P = No_Location and then Idx /= 0) + or else + (P /= No_Location and then Idx = 0) + then + return True; + else - if Elmt.Homonym_Number /= No_Uint then - Ctr := 1; + if P /= No_Location then + Sindex := Get_Source_File_Index (P); + Get_Name_String (File_Name (Sindex)); + end if; - Ent := E; - while Present (Homonym (Ent)) - and then Scope (Ent) = Scope (Homonym (Ent)) - loop - Ctr := Ctr + 1; - Ent := Homonym (Ent); - end loop; + return False; + end if; + end Different_Trace_Lengths; - if Ctr /= Elmt.Homonym_Number then - goto Continue; - end if; + function File_Mame_Match return Boolean is + Tmp_Idx : Positive; + End_Idx : Positive; + begin + + if Idx = 0 then + return False; + end if; + + for J in Idx .. Last loop + if Sloc_Trace (J) = ':' then + Tmp_Idx := J - 1; + exit; + end if; + end loop; + + for J in reverse Idx .. Tmp_Idx loop + if Sloc_Trace (J) /= ' ' then + End_Idx := J; + exit; + end if; + end loop; + + if Sloc_Trace (Idx .. End_Idx) = + Name_Buffer (1 .. Name_Len) + then + Idx := Tmp_Idx + 2; + + Idx := Skip_Spaces; + + return True; + else + return False; + end if; + + end File_Mame_Match; + + function Line_Num_Match return Boolean is + N : Int := 0; + begin + + if Idx = 0 then + return False; + end if; + + while Idx <= Last + and then + Sloc_Trace (Idx) in '0' .. '9' + loop + N := N * 10 + + (Character'Pos (Sloc_Trace (Idx)) - + Character'Pos ('0')); + + Idx := Idx + 1; + end loop; + + if Get_Physical_Line_Number (P) = + Physical_Line_Number (N) + then + + while Sloc_Trace (Idx) /= '[' + and then + Idx <= Last + loop + Idx := Idx + 1; + end loop; + + if Sloc_Trace (Idx) = '[' + and then + Idx < Last + then + Idx := Idx + 1; + Idx := Skip_Spaces; + else + Idx := 0; + end if; + + return True; + else + return False; + end if; + + end Line_Num_Match; + + function Skip_Spaces return Natural is + Res : Natural := Idx; + begin + + while Sloc_Trace (Res) = ' ' loop + Res := Res + 1; + + if Res > Last then + Res := 0; + exit; + end if; + end loop; + + return Res; + end Skip_Spaces; + + begin + P := Sloc (E); + Sindex := Get_Source_File_Index (P); + Get_Name_String (File_Name (Sindex)); + + Idx := Skip_Spaces; + + while Idx > 0 loop + + if not File_Mame_Match then + goto Continue; + elsif not Line_Num_Match then + goto Continue; + end if; + + if Different_Trace_Lengths then + goto Continue; + end if; + end loop; + end; end if; -- If we have a Result_Type, then we must have a function @@ -394,7 +571,14 @@ package body Sem_Elim is if Elmt.Parameter_Types /= null then Form := First_Formal (E); - if No (Form) and then Elmt.Parameter_Types = null then + if No (Form) + and then + Elmt.Parameter_Types'Length = 1 + and then + Elmt.Parameter_Types (1) = No_Name + then + -- Parameterless procedure matches + null; elsif Elmt.Parameter_Types = null then @@ -471,7 +655,7 @@ package body Sem_Elim is Arg_Entity : Node_Id; Arg_Parameter_Types : Node_Id; Arg_Result_Type : Node_Id; - Arg_Homonym_Number : Node_Id) + Arg_Source_Location : Node_Id) is Data : constant Access_Elim_Data := new Elim_Data; -- Build result data here @@ -593,7 +777,13 @@ package body Sem_Elim is and then Paren_Count (Arg_Parameter_Types) = 1 then String_To_Name_Buffer (Strval (Arg_Parameter_Types)); - Data.Parameter_Types := new Names'(1 => Name_Find); + + if Name_Len = 0 then + -- Parameterless procedure + Data.Parameter_Types := new Names'(1 => No_Name); + else + Data.Parameter_Types := new Names'(1 => Name_Find); + end if; -- Otherwise must be an aggregate @@ -647,25 +837,24 @@ package body Sem_Elim is Data.Result_Type := No_Name; end if; - -- Process Homonym_Number argument + -- Process Source_Location argument - if Present (Arg_Homonym_Number) then + if Present (Arg_Source_Location) then - if Nkind (Arg_Homonym_Number) /= N_Integer_Literal then + if Nkind (Arg_Source_Location) /= N_String_Literal then Error_Msg_N - ("Homonym_Number argument for pragma% must be integer literal", - Arg_Homonym_Number); + ("Source_Location argument for pragma% must be string literal", + Arg_Source_Location); return; end if; - Data.Homonym_Number := Intval (Arg_Homonym_Number); + String_To_Name_Buffer (Strval (Arg_Source_Location)); + Data.Source_Location := Name_Find; else - Data.Homonym_Number := No_Uint; + Data.Source_Location := No_Name; end if; - -- Now link this new entry into the hash table - Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data)); -- If we already have an entry with this same key, then link diff --git a/gcc/ada/sem_elim.ads b/gcc/ada/sem_elim.ads index 133219e..4e9911f 100644 --- a/gcc/ada/sem_elim.ads +++ b/gcc/ada/sem_elim.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-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- -- @@ -39,7 +39,7 @@ package Sem_Elim is Arg_Entity : Node_Id; Arg_Parameter_Types : Node_Id; Arg_Result_Type : Node_Id; - Arg_Homonym_Number : Node_Id); + Arg_Source_Location : Node_Id); -- Process eliminate pragma (given by Pragma_Node). The number of -- arguments has been checked, as well as possible optional identifiers, -- but no other checks have been made. This subprogram completes the diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 9c20310..b33973f 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -1954,6 +1954,7 @@ package body Sem_Eval is if Nkind (Operand) = N_Raise_Constraint_Error then Set_Raises_Constraint_Error (N); end if; + return; end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index ea1eab3..3b8c2ff 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1693,6 +1693,7 @@ package body Sem_Prag is Id : Node_Id; E1 : Entity_Id; Cname : Name_Id; + Comp_Unit : Unit_Number_Type; procedure Set_Convention_From_Pragma (E : Entity_Id); -- Set convention in entity E, and also flag that the entity has a @@ -1907,9 +1908,11 @@ package body Sem_Prag is end if; -- For the subprogram case, set proper convention for all homonyms - -- in same scope. + -- in same scope and the same declarative part, i.e. the same + -- compilation unit. else + Comp_Unit := Get_Source_Unit (E); Set_Convention_From_Pragma (E); -- Treat a pragma Import as an implicit body, for GPS use. @@ -1928,6 +1931,7 @@ package body Sem_Prag is -- than one Rep_Item chain, to be fixed later ??? if Comes_From_Source (E1) + and then Comp_Unit = Get_Source_Unit (E1) and then Nkind (Original_Node (Parent (E1))) /= N_Full_Type_Declaration then @@ -3556,10 +3560,11 @@ package body Sem_Prag is Set_Is_Statically_Allocated (E); -- Warn if the corresponding W flag is set and the pragma - -- comes from source. The latter may be not be true e.g. on + -- comes from source. The latter may not be true e.g. on -- VMS where we expand export pragmas for exception codes - -- associated with imported or exported exceptions. We don't - -- want the user to be warned about something he didn't write. + -- associated with imported or exported exceptions. We do + -- not want to generate a warning for something that the + -- user did not write. if Warn_On_Export_Import and then Comes_From_Source (Arg) @@ -5405,13 +5410,25 @@ package body Sem_Prag is -- [,[Entity =>] IDENTIFIER | -- SELECTED_COMPONENT | -- STRING_LITERAL] - -- [,[Parameter_Types =>] PARAMETER_TYPES] - -- [,[Result_Type =>] result_SUBTYPE_NAME] - -- [,[Homonym_Number =>] INTEGER_LITERAL]); + -- [,]OVERLOADING_RESOLUTION); + + -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE | + -- SOURCE_LOCATION + + -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE | + -- FUNCTION_PROFILE + + -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES + + -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,] + -- Result_Type => result_SUBTYPE_NAME] -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME}) -- SUBTYPE_NAME ::= STRING_LITERAL + -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE + -- SOURCE_TRACE ::= STRING_LITERAL + when Pragma_Eliminate => Eliminate : declare Args : Args_List (1 .. 5); Names : constant Name_List (1 .. 5) := ( @@ -5419,13 +5436,13 @@ package body Sem_Prag is Name_Entity, Name_Parameter_Types, Name_Result_Type, - Name_Homonym_Number); + Name_Source_Location); Unit_Name : Node_Id renames Args (1); Entity : Node_Id renames Args (2); Parameter_Types : Node_Id renames Args (3); Result_Type : Node_Id renames Args (4); - Homonym_Number : Node_Id renames Args (5); + Source_Location : Node_Id renames Args (5); begin GNAT_Pragma; @@ -5441,18 +5458,29 @@ package body Sem_Prag is or else Present (Result_Type) or else - Present (Homonym_Number)) + Present (Source_Location)) then Error_Pragma ("missing Entity argument for pragma%"); end if; + if (Present (Parameter_Types) + or else + Present (Result_Type)) + and then + Present (Source_Location) + then + Error_Pragma + ("parameter profile and source location can not " & + "be used together in pragma%"); + end if; + Process_Eliminate_Pragma (N, Unit_Name, Entity, Parameter_Types, Result_Type, - Homonym_Number); + Source_Location); end Eliminate; -------------------------- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 103ebfd..97f9838 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3730,6 +3730,7 @@ package body Sem_Res is -- we will try later to detect some cases here at run time by -- expanding checking code (see Detect_Infinite_Recursion in -- package Exp_Ch6). + -- If the recursive call is within a handler we do not emit a -- warning, because this is a common idiom: loop until input -- is correct, catch illegal input in handler and restart. @@ -6866,6 +6867,12 @@ package body Sem_Res is elsif Is_Numeric_Type (Target_Type) then if Opnd_Type = Universal_Fixed then return True; + + elsif (In_Instance or else In_Inlined_Body) + and then not Comes_From_Source (N) + then + return True; + else return Conversion_Check (Is_Numeric_Type (Opnd_Type), "illegal operand for numeric conversion"); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a3adc6e..ddded5c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2674,6 +2674,23 @@ package body Sem_Util is return Task_Body_Procedure (Declaration_Node (Root_Type (E))); end Get_Task_Body_Procedure; + ---------------------- + -- Has_Declarations -- + ---------------------- + + function Has_Declarations (N : Node_Id) return Boolean is + K : constant Node_Kind := Nkind (N); + begin + return K = N_Accept_Statement + or else K = N_Block_Statement + or else K = N_Compilation_Unit_Aux + or else K = N_Entry_Body + or else K = N_Package_Body + or else K = N_Protected_Body + or else K = N_Subprogram_Body + or else K = N_Task_Body; + end Has_Declarations; + -------------------- -- Has_Infinities -- -------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 9b8c4c1..9a35d8d 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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- -- @@ -357,6 +357,9 @@ package Sem_Util is -- Task_Body_Procedure field from the corresponding task type -- declaration. + function Has_Declarations (N : Node_Id) return Boolean; + -- Determines if the node can have declarations + function Has_Infinities (E : Entity_Id) return Boolean; -- Determines if the range of the floating-point type E includes -- infinities. Returns False if E is not a floating-point type. @@ -468,8 +471,8 @@ package Sem_Util is -- an lvalue, but it can answer True when N is not an lvalue. An lvalue is -- defined as any expression which appears in a context where a name is -- required by the syntax, and the identity, rather than merely the value - -- of the node is needed (for example, the prefix of an attribute is in - -- this category). + -- of the node is needed (for example, the prefix of an Access attribute + -- is in this category). function Is_Library_Level_Entity (E : Entity_Id) return Boolean; -- A library-level declaration is one that is accessible from Standard, diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index e19321a..65ee94e 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -126,6 +126,14 @@ package body Sinfo is return Node3 (N); end Access_Definition; + function Access_To_Subprogram_Definition + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Definition); + return Node3 (N); + end Access_To_Subprogram_Definition; + function Access_Types_To_Process (N : Node_Id) return Elist_Id is begin @@ -2612,6 +2620,14 @@ package body Sinfo is Set_Node3_With_Parent (N, Val); end Set_Access_Definition; + procedure Set_Access_To_Subprogram_Definition + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Definition); + Set_Node3_With_Parent (N, Val); + end Set_Access_To_Subprogram_Definition; + procedure Set_Access_Types_To_Process (N : Node_Id; Val : Elist_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index c86ac9d..63a6e0c 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -2705,6 +2705,9 @@ package Sinfo is -- ACCESS_DEFINITION ::= -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK + -- | ACCESS_TO_SUBPROGRAM_DEFINITION + + -- Note: access to subprograms are an Ada 0Y (AI-254) extension -- N_Access_Definition -- Sloc points to ACCESS @@ -2712,6 +2715,7 @@ package Sinfo is -- All_Present (Flag15) -- Constant_Present (Flag17) -- Subtype_Mark (Node4) + -- Access_To_Subprogram_Definition (Node3) (set to Empty if not present) ----------------------------------------- -- 3.10.1 Incomplete Type Declaration -- @@ -4242,7 +4246,7 @@ package Sinfo is -- PRIVATE_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] - -- is [abstract] tagged] [limited] private; + -- is [[abstract] tagged] [limited] private; -- Note: TAGGED is not permitted in Ada 83 mode @@ -6929,6 +6933,9 @@ package Sinfo is function Access_Definition (N : Node_Id) return Node_Id; -- Node3 + function Access_To_Subprogram_Definition + (N : Node_Id) return Node_Id; -- Node3 + function Access_Types_To_Process (N : Node_Id) return Elist_Id; -- Elist2 @@ -7721,6 +7728,9 @@ package Sinfo is procedure Set_Access_Definition (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Access_To_Subprogram_Definition + (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Access_Types_To_Process (N : Node_Id; Val : Elist_Id); -- Elist2 @@ -8514,6 +8524,7 @@ package Sinfo is pragma Inline (Accept_Handler_Records); pragma Inline (Accept_Statement); pragma Inline (Access_Definition); + pragma Inline (Access_To_Subprogram_Definition); pragma Inline (Access_Types_To_Process); pragma Inline (Actions); pragma Inline (Activation_Chain_Entity); @@ -8775,6 +8786,7 @@ package Sinfo is pragma Inline (Set_Accept_Handler_Records); pragma Inline (Set_Accept_Statement); pragma Inline (Set_Access_Definition); + pragma Inline (Set_Access_To_Subprogram_Definition); pragma Inline (Set_Access_Types_To_Process); pragma Inline (Set_Actions); pragma Inline (Set_Activation_Chain_Entity); diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index 70b9608..7eec50a 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -92,6 +92,9 @@ package body Snames is "finalize#" & "next#" & "prev#" & + "_typecode#" & + "_from_any#" & + "_to_any#" & "allocate#" & "deallocate#" & "dereference#" & @@ -120,16 +123,25 @@ package body Snames is "async#" & "get_active_partition_id#" & "get_rci_package_receiver#" & + "get_rci_package_ref#" & "origin#" & "params#" & "partition#" & "partition_interface#" & "ras#" & + "call#" & "rci_name#" & "receiver#" & "result#" & "rpc#" & "subp_id#" & + "operation#" & + "argument#" & + "arg_modes#" & + "handler#" & + "target#" & + "req#" & + "obj_typecode#" & "Oabs#" & "Oand#" & "Omod#" & diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index 2985ddb..562a280 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -183,92 +183,107 @@ package Snames is Name_Next : constant Name_Id := N + 033; Name_Prev : constant Name_Id := N + 034; + -- Names of TSS routines for implementation of DSA over PolyORB + + Name_uTypeCode : constant Name_Id := N + 035; + Name_uFrom_Any : constant Name_Id := N + 036; + Name_uTo_Any : constant Name_Id := N + 037; + -- Names of allocation routines, also needed by expander - Name_Allocate : constant Name_Id := N + 035; - Name_Deallocate : constant Name_Id := N + 036; - Name_Dereference : constant Name_Id := N + 037; + Name_Allocate : constant Name_Id := N + 038; + Name_Deallocate : constant Name_Id := N + 039; + Name_Dereference : constant Name_Id := N + 040; -- Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge) - First_Text_IO_Package : constant Name_Id := N + 038; - Name_Decimal_IO : constant Name_Id := N + 038; - Name_Enumeration_IO : constant Name_Id := N + 039; - Name_Fixed_IO : constant Name_Id := N + 040; - Name_Float_IO : constant Name_Id := N + 041; - Name_Integer_IO : constant Name_Id := N + 042; - Name_Modular_IO : constant Name_Id := N + 043; - Last_Text_IO_Package : constant Name_Id := N + 043; + First_Text_IO_Package : constant Name_Id := N + 041; + Name_Decimal_IO : constant Name_Id := N + 041; + Name_Enumeration_IO : constant Name_Id := N + 042; + Name_Fixed_IO : constant Name_Id := N + 043; + Name_Float_IO : constant Name_Id := N + 044; + Name_Integer_IO : constant Name_Id := N + 045; + Name_Modular_IO : constant Name_Id := N + 046; + Last_Text_IO_Package : constant Name_Id := N + 046; subtype Text_IO_Package_Name is Name_Id range First_Text_IO_Package .. Last_Text_IO_Package; -- Names of files in library for Ada.Text_IO and Ada.Wide_Text_IO - Name_a_textio : constant Name_Id := N + 044; - Name_a_witeio : constant Name_Id := N + 045; + Name_a_textio : constant Name_Id := N + 047; + Name_a_witeio : constant Name_Id := N + 048; -- Some miscellaneous names used for error detection/recovery - Name_Const : constant Name_Id := N + 046; - Name_Error : constant Name_Id := N + 047; - Name_Go : constant Name_Id := N + 048; - Name_Put : constant Name_Id := N + 049; - Name_Put_Line : constant Name_Id := N + 050; - Name_To : constant Name_Id := N + 051; + Name_Const : constant Name_Id := N + 049; + Name_Error : constant Name_Id := N + 050; + Name_Go : constant Name_Id := N + 051; + Name_Put : constant Name_Id := N + 052; + Name_Put_Line : constant Name_Id := N + 053; + Name_To : constant Name_Id := N + 054; -- Names for packages that are treated specially by the compiler - Name_Finalization : constant Name_Id := N + 052; - Name_Finalization_Root : constant Name_Id := N + 053; - Name_Interfaces : constant Name_Id := N + 054; - Name_Standard : constant Name_Id := N + 055; - Name_System : constant Name_Id := N + 056; - Name_Text_IO : constant Name_Id := N + 057; - Name_Wide_Text_IO : constant Name_Id := N + 058; + Name_Finalization : constant Name_Id := N + 055; + Name_Finalization_Root : constant Name_Id := N + 056; + Name_Interfaces : constant Name_Id := N + 057; + Name_Standard : constant Name_Id := N + 058; + Name_System : constant Name_Id := N + 059; + Name_Text_IO : constant Name_Id := N + 060; + Name_Wide_Text_IO : constant Name_Id := N + 061; -- Names of identifiers used in expanding distribution stubs - Name_Addr : constant Name_Id := N + 059; - Name_Async : constant Name_Id := N + 060; - Name_Get_Active_Partition_ID : constant Name_Id := N + 061; - Name_Get_RCI_Package_Receiver : constant Name_Id := N + 062; - Name_Origin : constant Name_Id := N + 063; - Name_Params : constant Name_Id := N + 064; - Name_Partition : constant Name_Id := N + 065; - Name_Partition_Interface : constant Name_Id := N + 066; - Name_Ras : constant Name_Id := N + 067; - Name_RCI_Name : constant Name_Id := N + 068; - Name_Receiver : constant Name_Id := N + 069; - Name_Result : constant Name_Id := N + 070; - Name_Rpc : constant Name_Id := N + 071; - Name_Subp_Id : constant Name_Id := N + 072; + Name_Addr : constant Name_Id := N + 062; + Name_Async : constant Name_Id := N + 063; + Name_Get_Active_Partition_ID : constant Name_Id := N + 064; + Name_Get_RCI_Package_Receiver : constant Name_Id := N + 065; + Name_Get_RCI_Package_Ref : constant Name_Id := N + 066; + Name_Origin : constant Name_Id := N + 067; + Name_Params : constant Name_Id := N + 068; + Name_Partition : constant Name_Id := N + 069; + Name_Partition_Interface : constant Name_Id := N + 070; + Name_Ras : constant Name_Id := N + 071; + Name_Call : constant Name_Id := N + 072; + Name_RCI_Name : constant Name_Id := N + 073; + Name_Receiver : constant Name_Id := N + 074; + Name_Result : constant Name_Id := N + 075; + Name_Rpc : constant Name_Id := N + 076; + Name_Subp_Id : constant Name_Id := N + 077; + Name_Operation : constant Name_Id := N + 078; + Name_Argument : constant Name_Id := N + 079; + Name_Arg_Modes : constant Name_Id := N + 080; + Name_Handler : constant Name_Id := N + 081; + Name_Target : constant Name_Id := N + 082; + Name_Req : constant Name_Id := N + 083; + Name_Obj_TypeCode : constant Name_Id := N + 084; -- Operator Symbol entries. The actual names have an upper case O at -- the start in place of the Op_ prefix (e.g. the actual name that -- corresponds to Name_Op_Abs is "Oabs". - First_Operator_Name : constant Name_Id := N + 073; - Name_Op_Abs : constant Name_Id := N + 073; -- "abs" - Name_Op_And : constant Name_Id := N + 074; -- "and" - Name_Op_Mod : constant Name_Id := N + 075; -- "mod" - Name_Op_Not : constant Name_Id := N + 076; -- "not" - Name_Op_Or : constant Name_Id := N + 077; -- "or" - Name_Op_Rem : constant Name_Id := N + 078; -- "rem" - Name_Op_Xor : constant Name_Id := N + 079; -- "xor" - Name_Op_Eq : constant Name_Id := N + 080; -- "=" - Name_Op_Ne : constant Name_Id := N + 081; -- "/=" - Name_Op_Lt : constant Name_Id := N + 082; -- "<" - Name_Op_Le : constant Name_Id := N + 083; -- "<=" - Name_Op_Gt : constant Name_Id := N + 084; -- ">" - Name_Op_Ge : constant Name_Id := N + 085; -- ">=" - Name_Op_Add : constant Name_Id := N + 086; -- "+" - Name_Op_Subtract : constant Name_Id := N + 087; -- "-" - Name_Op_Concat : constant Name_Id := N + 088; -- "&" - Name_Op_Multiply : constant Name_Id := N + 089; -- "*" - Name_Op_Divide : constant Name_Id := N + 090; -- "/" - Name_Op_Expon : constant Name_Id := N + 091; -- "**" - Last_Operator_Name : constant Name_Id := N + 091; + First_Operator_Name : constant Name_Id := N + 085; + Name_Op_Abs : constant Name_Id := N + 085; -- "abs" + Name_Op_And : constant Name_Id := N + 086; -- "and" + Name_Op_Mod : constant Name_Id := N + 087; -- "mod" + Name_Op_Not : constant Name_Id := N + 088; -- "not" + Name_Op_Or : constant Name_Id := N + 089; -- "or" + Name_Op_Rem : constant Name_Id := N + 090; -- "rem" + Name_Op_Xor : constant Name_Id := N + 091; -- "xor" + Name_Op_Eq : constant Name_Id := N + 092; -- "=" + Name_Op_Ne : constant Name_Id := N + 093; -- "/=" + Name_Op_Lt : constant Name_Id := N + 094; -- "<" + Name_Op_Le : constant Name_Id := N + 095; -- "<=" + Name_Op_Gt : constant Name_Id := N + 096; -- ">" + Name_Op_Ge : constant Name_Id := N + 097; -- ">=" + Name_Op_Add : constant Name_Id := N + 098; -- "+" + Name_Op_Subtract : constant Name_Id := N + 099; -- "-" + Name_Op_Concat : constant Name_Id := N + 100; -- "&" + Name_Op_Multiply : constant Name_Id := N + 101; -- "*" + Name_Op_Divide : constant Name_Id := N + 102; -- "/" + Name_Op_Expon : constant Name_Id := N + 103; -- "**" + Last_Operator_Name : constant Name_Id := N + 103; -- Names for all pragmas recognized by GNAT. The entries with the comment -- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95. @@ -291,61 +306,61 @@ package Snames is -- only in GNAT for the AAMP. They are ignored in other versions with -- appropriate warnings. - First_Pragma_Name : constant Name_Id := N + 092; + First_Pragma_Name : constant Name_Id := N + 104; -- Configuration pragmas are grouped at start - Name_Ada_83 : constant Name_Id := N + 092; -- GNAT - Name_Ada_95 : constant Name_Id := N + 093; -- GNAT - Name_C_Pass_By_Copy : constant Name_Id := N + 094; -- GNAT - Name_Compile_Time_Warning : constant Name_Id := N + 095; -- GNAT - Name_Component_Alignment : constant Name_Id := N + 096; -- GNAT - Name_Convention_Identifier : constant Name_Id := N + 097; -- GNAT - Name_Discard_Names : constant Name_Id := N + 098; - Name_Elaboration_Checks : constant Name_Id := N + 099; -- GNAT - Name_Eliminate : constant Name_Id := N + 100; -- GNAT - Name_Explicit_Overriding : constant Name_Id := N + 101; - Name_Extend_System : constant Name_Id := N + 102; -- GNAT - Name_Extensions_Allowed : constant Name_Id := N + 103; -- GNAT - Name_External_Name_Casing : constant Name_Id := N + 104; -- GNAT - Name_Float_Representation : constant Name_Id := N + 105; -- GNAT - Name_Initialize_Scalars : constant Name_Id := N + 106; -- GNAT - Name_Interrupt_State : constant Name_Id := N + 107; -- GNAT - Name_License : constant Name_Id := N + 108; -- GNAT - Name_Locking_Policy : constant Name_Id := N + 109; - Name_Long_Float : constant Name_Id := N + 110; -- VMS - Name_No_Run_Time : constant Name_Id := N + 111; -- GNAT - Name_No_Strict_Aliasing : constant Name_Id := N + 112; -- GNAT - Name_Normalize_Scalars : constant Name_Id := N + 113; - Name_Polling : constant Name_Id := N + 114; -- GNAT - Name_Persistent_Data : constant Name_Id := N + 115; -- GNAT - Name_Persistent_Object : constant Name_Id := N + 116; -- GNAT - Name_Profile : constant Name_Id := N + 117; -- Ada0Y - Name_Propagate_Exceptions : constant Name_Id := N + 118; -- GNAT - Name_Queuing_Policy : constant Name_Id := N + 119; - Name_Ravenscar : constant Name_Id := N + 120; - Name_Restricted_Run_Time : constant Name_Id := N + 121; - Name_Restrictions : constant Name_Id := N + 122; - Name_Restriction_Warnings : constant Name_Id := N + 123; -- GNAT - Name_Reviewable : constant Name_Id := N + 124; - Name_Source_File_Name : constant Name_Id := N + 125; -- GNAT - Name_Source_File_Name_Project : constant Name_Id := N + 126; -- GNAT - Name_Style_Checks : constant Name_Id := N + 127; -- GNAT - Name_Suppress : constant Name_Id := N + 128; - Name_Suppress_Exception_Locations : constant Name_Id := N + 129; -- GNAT - Name_Task_Dispatching_Policy : constant Name_Id := N + 130; - Name_Universal_Data : constant Name_Id := N + 131; -- AAMP - Name_Unsuppress : constant Name_Id := N + 132; -- GNAT - Name_Use_VADS_Size : constant Name_Id := N + 133; -- GNAT - Name_Validity_Checks : constant Name_Id := N + 134; -- GNAT - Name_Warnings : constant Name_Id := N + 135; -- GNAT - Last_Configuration_Pragma_Name : constant Name_Id := N + 135; + Name_Ada_83 : constant Name_Id := N + 104; -- GNAT + Name_Ada_95 : constant Name_Id := N + 105; -- GNAT + Name_C_Pass_By_Copy : constant Name_Id := N + 106; -- GNAT + Name_Compile_Time_Warning : constant Name_Id := N + 107; -- GNAT + Name_Component_Alignment : constant Name_Id := N + 108; -- GNAT + Name_Convention_Identifier : constant Name_Id := N + 109; -- GNAT + Name_Discard_Names : constant Name_Id := N + 110; + Name_Elaboration_Checks : constant Name_Id := N + 111; -- GNAT + Name_Eliminate : constant Name_Id := N + 112; -- GNAT + Name_Explicit_Overriding : constant Name_Id := N + 113; + Name_Extend_System : constant Name_Id := N + 114; -- GNAT + Name_Extensions_Allowed : constant Name_Id := N + 115; -- GNAT + Name_External_Name_Casing : constant Name_Id := N + 116; -- GNAT + Name_Float_Representation : constant Name_Id := N + 117; -- GNAT + Name_Initialize_Scalars : constant Name_Id := N + 118; -- GNAT + Name_Interrupt_State : constant Name_Id := N + 119; -- GNAT + Name_License : constant Name_Id := N + 120; -- GNAT + Name_Locking_Policy : constant Name_Id := N + 121; + Name_Long_Float : constant Name_Id := N + 122; -- VMS + Name_No_Run_Time : constant Name_Id := N + 123; -- GNAT + Name_No_Strict_Aliasing : constant Name_Id := N + 124; -- GNAT + Name_Normalize_Scalars : constant Name_Id := N + 125; + Name_Polling : constant Name_Id := N + 126; -- GNAT + Name_Persistent_Data : constant Name_Id := N + 127; -- GNAT + Name_Persistent_Object : constant Name_Id := N + 128; -- GNAT + Name_Profile : constant Name_Id := N + 129; -- Ada0Y + Name_Propagate_Exceptions : constant Name_Id := N + 130; -- GNAT + Name_Queuing_Policy : constant Name_Id := N + 131; + Name_Ravenscar : constant Name_Id := N + 132; + Name_Restricted_Run_Time : constant Name_Id := N + 133; + Name_Restrictions : constant Name_Id := N + 134; + Name_Restriction_Warnings : constant Name_Id := N + 135; -- GNAT + Name_Reviewable : constant Name_Id := N + 136; + Name_Source_File_Name : constant Name_Id := N + 137; -- GNAT + Name_Source_File_Name_Project : constant Name_Id := N + 138; -- GNAT + Name_Style_Checks : constant Name_Id := N + 139; -- GNAT + Name_Suppress : constant Name_Id := N + 140; + Name_Suppress_Exception_Locations : constant Name_Id := N + 141; -- GNAT + Name_Task_Dispatching_Policy : constant Name_Id := N + 142; + Name_Universal_Data : constant Name_Id := N + 143; -- AAMP + Name_Unsuppress : constant Name_Id := N + 144; -- GNAT + Name_Use_VADS_Size : constant Name_Id := N + 145; -- GNAT + Name_Validity_Checks : constant Name_Id := N + 146; -- GNAT + Name_Warnings : constant Name_Id := N + 147; -- GNAT + Last_Configuration_Pragma_Name : constant Name_Id := N + 147; -- Remaining pragma names - Name_Abort_Defer : constant Name_Id := N + 136; -- GNAT - Name_All_Calls_Remote : constant Name_Id := N + 137; - Name_Annotate : constant Name_Id := N + 138; -- GNAT + Name_Abort_Defer : constant Name_Id := N + 148; -- GNAT + Name_All_Calls_Remote : constant Name_Id := N + 149; + Name_Annotate : constant Name_Id := N + 150; -- GNAT -- Note: AST_Entry is not in this list because its name matches the -- name of the corresponding attribute. However, it is included in the @@ -353,78 +368,78 @@ package Snames is -- and Check_Pragma_Id correctly recognize and process Name_AST_Entry. -- AST_Entry is a VMS specific pragma. - Name_Assert : constant Name_Id := N + 139; -- GNAT - Name_Asynchronous : constant Name_Id := N + 140; - Name_Atomic : constant Name_Id := N + 141; - Name_Atomic_Components : constant Name_Id := N + 142; - Name_Attach_Handler : constant Name_Id := N + 143; - Name_Comment : constant Name_Id := N + 144; -- GNAT - Name_Common_Object : constant Name_Id := N + 145; -- GNAT - Name_Complex_Representation : constant Name_Id := N + 146; -- GNAT - Name_Controlled : constant Name_Id := N + 147; - Name_Convention : constant Name_Id := N + 148; - Name_CPP_Class : constant Name_Id := N + 149; -- GNAT - Name_CPP_Constructor : constant Name_Id := N + 150; -- GNAT - Name_CPP_Virtual : constant Name_Id := N + 151; -- GNAT - Name_CPP_Vtable : constant Name_Id := N + 152; -- GNAT - Name_Debug : constant Name_Id := N + 153; -- GNAT - Name_Elaborate : constant Name_Id := N + 154; -- Ada 83 - Name_Elaborate_All : constant Name_Id := N + 155; - Name_Elaborate_Body : constant Name_Id := N + 156; - Name_Export : constant Name_Id := N + 157; - Name_Export_Exception : constant Name_Id := N + 158; -- VMS - Name_Export_Function : constant Name_Id := N + 159; -- GNAT - Name_Export_Object : constant Name_Id := N + 160; -- GNAT - Name_Export_Procedure : constant Name_Id := N + 161; -- GNAT - Name_Export_Value : constant Name_Id := N + 162; -- GNAT - Name_Export_Valued_Procedure : constant Name_Id := N + 163; -- GNAT - Name_External : constant Name_Id := N + 164; -- GNAT - Name_Finalize_Storage_Only : constant Name_Id := N + 165; -- GNAT - Name_Ident : constant Name_Id := N + 166; -- VMS - Name_Import : constant Name_Id := N + 167; - Name_Import_Exception : constant Name_Id := N + 168; -- VMS - Name_Import_Function : constant Name_Id := N + 169; -- GNAT - Name_Import_Object : constant Name_Id := N + 170; -- GNAT - Name_Import_Procedure : constant Name_Id := N + 171; -- GNAT - Name_Import_Valued_Procedure : constant Name_Id := N + 172; -- GNAT - Name_Inline : constant Name_Id := N + 173; - Name_Inline_Always : constant Name_Id := N + 174; -- GNAT - Name_Inline_Generic : constant Name_Id := N + 175; -- GNAT - Name_Inspection_Point : constant Name_Id := N + 176; - Name_Interface : constant Name_Id := N + 177; -- Ada 83 - Name_Interface_Name : constant Name_Id := N + 178; -- GNAT - Name_Interrupt_Handler : constant Name_Id := N + 179; - Name_Interrupt_Priority : constant Name_Id := N + 180; - Name_Java_Constructor : constant Name_Id := N + 181; -- GNAT - Name_Java_Interface : constant Name_Id := N + 182; -- GNAT - Name_Keep_Names : constant Name_Id := N + 183; -- GNAT - Name_Link_With : constant Name_Id := N + 184; -- GNAT - Name_Linker_Alias : constant Name_Id := N + 185; -- GNAT - Name_Linker_Options : constant Name_Id := N + 186; - Name_Linker_Section : constant Name_Id := N + 187; -- GNAT - Name_List : constant Name_Id := N + 188; - Name_Machine_Attribute : constant Name_Id := N + 189; -- GNAT - Name_Main : constant Name_Id := N + 190; -- GNAT - Name_Main_Storage : constant Name_Id := N + 191; -- GNAT - Name_Memory_Size : constant Name_Id := N + 192; -- Ada 83 - Name_No_Return : constant Name_Id := N + 193; -- GNAT - Name_Obsolescent : constant Name_Id := N + 194; -- GNAT - Name_Optimize : constant Name_Id := N + 195; - Name_Optional_Overriding : constant Name_Id := N + 196; - Name_Overriding : constant Name_Id := N + 197; - Name_Pack : constant Name_Id := N + 198; - Name_Page : constant Name_Id := N + 199; - Name_Passive : constant Name_Id := N + 200; -- GNAT - Name_Preelaborate : constant Name_Id := N + 201; - Name_Priority : constant Name_Id := N + 202; - Name_Psect_Object : constant Name_Id := N + 203; -- VMS - Name_Pure : constant Name_Id := N + 204; - Name_Pure_Function : constant Name_Id := N + 205; -- GNAT - Name_Remote_Call_Interface : constant Name_Id := N + 206; - Name_Remote_Types : constant Name_Id := N + 207; - Name_Share_Generic : constant Name_Id := N + 208; -- GNAT - Name_Shared : constant Name_Id := N + 209; -- Ada 83 - Name_Shared_Passive : constant Name_Id := N + 210; + Name_Assert : constant Name_Id := N + 151; -- GNAT + Name_Asynchronous : constant Name_Id := N + 152; + Name_Atomic : constant Name_Id := N + 153; + Name_Atomic_Components : constant Name_Id := N + 154; + Name_Attach_Handler : constant Name_Id := N + 155; + Name_Comment : constant Name_Id := N + 156; -- GNAT + Name_Common_Object : constant Name_Id := N + 157; -- GNAT + Name_Complex_Representation : constant Name_Id := N + 158; -- GNAT + Name_Controlled : constant Name_Id := N + 159; + Name_Convention : constant Name_Id := N + 160; + Name_CPP_Class : constant Name_Id := N + 161; -- GNAT + Name_CPP_Constructor : constant Name_Id := N + 162; -- GNAT + Name_CPP_Virtual : constant Name_Id := N + 163; -- GNAT + Name_CPP_Vtable : constant Name_Id := N + 164; -- GNAT + Name_Debug : constant Name_Id := N + 165; -- GNAT + Name_Elaborate : constant Name_Id := N + 166; -- Ada 83 + Name_Elaborate_All : constant Name_Id := N + 167; + Name_Elaborate_Body : constant Name_Id := N + 168; + Name_Export : constant Name_Id := N + 169; + Name_Export_Exception : constant Name_Id := N + 170; -- VMS + Name_Export_Function : constant Name_Id := N + 171; -- GNAT + Name_Export_Object : constant Name_Id := N + 172; -- GNAT + Name_Export_Procedure : constant Name_Id := N + 173; -- GNAT + Name_Export_Value : constant Name_Id := N + 174; -- GNAT + Name_Export_Valued_Procedure : constant Name_Id := N + 175; -- GNAT + Name_External : constant Name_Id := N + 176; -- GNAT + Name_Finalize_Storage_Only : constant Name_Id := N + 177; -- GNAT + Name_Ident : constant Name_Id := N + 178; -- VMS + Name_Import : constant Name_Id := N + 179; + Name_Import_Exception : constant Name_Id := N + 180; -- VMS + Name_Import_Function : constant Name_Id := N + 181; -- GNAT + Name_Import_Object : constant Name_Id := N + 182; -- GNAT + Name_Import_Procedure : constant Name_Id := N + 183; -- GNAT + Name_Import_Valued_Procedure : constant Name_Id := N + 184; -- GNAT + Name_Inline : constant Name_Id := N + 185; + Name_Inline_Always : constant Name_Id := N + 186; -- GNAT + Name_Inline_Generic : constant Name_Id := N + 187; -- GNAT + Name_Inspection_Point : constant Name_Id := N + 188; + Name_Interface : constant Name_Id := N + 189; -- Ada 83 + Name_Interface_Name : constant Name_Id := N + 190; -- GNAT + Name_Interrupt_Handler : constant Name_Id := N + 191; + Name_Interrupt_Priority : constant Name_Id := N + 192; + Name_Java_Constructor : constant Name_Id := N + 193; -- GNAT + Name_Java_Interface : constant Name_Id := N + 194; -- GNAT + Name_Keep_Names : constant Name_Id := N + 195; -- GNAT + Name_Link_With : constant Name_Id := N + 196; -- GNAT + Name_Linker_Alias : constant Name_Id := N + 197; -- GNAT + Name_Linker_Options : constant Name_Id := N + 198; + Name_Linker_Section : constant Name_Id := N + 199; -- GNAT + Name_List : constant Name_Id := N + 200; + Name_Machine_Attribute : constant Name_Id := N + 201; -- GNAT + Name_Main : constant Name_Id := N + 202; -- GNAT + Name_Main_Storage : constant Name_Id := N + 203; -- GNAT + Name_Memory_Size : constant Name_Id := N + 204; -- Ada 83 + Name_No_Return : constant Name_Id := N + 205; -- GNAT + Name_Obsolescent : constant Name_Id := N + 206; -- GNAT + Name_Optimize : constant Name_Id := N + 207; + Name_Optional_Overriding : constant Name_Id := N + 208; + Name_Overriding : constant Name_Id := N + 209; + Name_Pack : constant Name_Id := N + 210; + Name_Page : constant Name_Id := N + 211; + Name_Passive : constant Name_Id := N + 212; -- GNAT + Name_Preelaborate : constant Name_Id := N + 213; + Name_Priority : constant Name_Id := N + 214; + Name_Psect_Object : constant Name_Id := N + 215; -- VMS + Name_Pure : constant Name_Id := N + 216; + Name_Pure_Function : constant Name_Id := N + 217; -- GNAT + Name_Remote_Call_Interface : constant Name_Id := N + 218; + Name_Remote_Types : constant Name_Id := N + 219; + Name_Share_Generic : constant Name_Id := N + 220; -- GNAT + Name_Shared : constant Name_Id := N + 221; -- Ada 83 + Name_Shared_Passive : constant Name_Id := N + 222; -- Note: Storage_Size is not in this list because its name matches the -- name of the corresponding attribute. However, it is included in the @@ -434,27 +449,27 @@ package Snames is -- Note: Storage_Unit is also omitted from the list because of a clash -- with an attribute name, and is treated similarly. - Name_Source_Reference : constant Name_Id := N + 211; -- GNAT - Name_Stream_Convert : constant Name_Id := N + 212; -- GNAT - Name_Subtitle : constant Name_Id := N + 213; -- GNAT - Name_Suppress_All : constant Name_Id := N + 214; -- GNAT - Name_Suppress_Debug_Info : constant Name_Id := N + 215; -- GNAT - Name_Suppress_Initialization : constant Name_Id := N + 216; -- GNAT - Name_System_Name : constant Name_Id := N + 217; -- Ada 83 - Name_Task_Info : constant Name_Id := N + 218; -- GNAT - Name_Task_Name : constant Name_Id := N + 219; -- GNAT - Name_Task_Storage : constant Name_Id := N + 220; -- VMS - Name_Thread_Body : constant Name_Id := N + 221; -- GNAT - Name_Time_Slice : constant Name_Id := N + 222; -- GNAT - Name_Title : constant Name_Id := N + 223; -- GNAT - Name_Unchecked_Union : constant Name_Id := N + 224; -- GNAT - Name_Unimplemented_Unit : constant Name_Id := N + 225; -- GNAT - Name_Unreferenced : constant Name_Id := N + 226; -- GNAT - Name_Unreserve_All_Interrupts : constant Name_Id := N + 227; -- GNAT - Name_Volatile : constant Name_Id := N + 228; - Name_Volatile_Components : constant Name_Id := N + 229; - Name_Weak_External : constant Name_Id := N + 230; -- GNAT - Last_Pragma_Name : constant Name_Id := N + 230; + Name_Source_Reference : constant Name_Id := N + 223; -- GNAT + Name_Stream_Convert : constant Name_Id := N + 224; -- GNAT + Name_Subtitle : constant Name_Id := N + 225; -- GNAT + Name_Suppress_All : constant Name_Id := N + 226; -- GNAT + Name_Suppress_Debug_Info : constant Name_Id := N + 227; -- GNAT + Name_Suppress_Initialization : constant Name_Id := N + 228; -- GNAT + Name_System_Name : constant Name_Id := N + 229; -- Ada 83 + Name_Task_Info : constant Name_Id := N + 230; -- GNAT + Name_Task_Name : constant Name_Id := N + 231; -- GNAT + Name_Task_Storage : constant Name_Id := N + 232; -- VMS + Name_Thread_Body : constant Name_Id := N + 233; -- GNAT + Name_Time_Slice : constant Name_Id := N + 234; -- GNAT + Name_Title : constant Name_Id := N + 235; -- GNAT + Name_Unchecked_Union : constant Name_Id := N + 236; -- GNAT + Name_Unimplemented_Unit : constant Name_Id := N + 237; -- GNAT + Name_Unreferenced : constant Name_Id := N + 238; -- GNAT + Name_Unreserve_All_Interrupts : constant Name_Id := N + 239; -- GNAT + Name_Volatile : constant Name_Id := N + 240; + Name_Volatile_Components : constant Name_Id := N + 241; + Name_Weak_External : constant Name_Id := N + 242; -- GNAT + Last_Pragma_Name : constant Name_Id := N + 242; -- Language convention names for pragma Convention/Export/Import/Interface -- Note that Name_C is not included in this list, since it was already @@ -465,98 +480,98 @@ package Snames is -- Entry and Protected, this is because these conventions cannot be -- specified by a pragma. - First_Convention_Name : constant Name_Id := N + 231; - Name_Ada : constant Name_Id := N + 231; - Name_Assembler : constant Name_Id := N + 232; - Name_COBOL : constant Name_Id := N + 233; - Name_CPP : constant Name_Id := N + 234; - Name_Fortran : constant Name_Id := N + 235; - Name_Intrinsic : constant Name_Id := N + 236; - Name_Java : constant Name_Id := N + 237; - Name_Stdcall : constant Name_Id := N + 238; - Name_Stubbed : constant Name_Id := N + 239; - Last_Convention_Name : constant Name_Id := N + 239; + First_Convention_Name : constant Name_Id := N + 243; + Name_Ada : constant Name_Id := N + 243; + Name_Assembler : constant Name_Id := N + 244; + Name_COBOL : constant Name_Id := N + 245; + Name_CPP : constant Name_Id := N + 246; + Name_Fortran : constant Name_Id := N + 247; + Name_Intrinsic : constant Name_Id := N + 248; + Name_Java : constant Name_Id := N + 249; + Name_Stdcall : constant Name_Id := N + 250; + Name_Stubbed : constant Name_Id := N + 251; + Last_Convention_Name : constant Name_Id := N + 251; -- The following names are preset as synonyms for Assembler - Name_Asm : constant Name_Id := N + 240; - Name_Assembly : constant Name_Id := N + 241; + Name_Asm : constant Name_Id := N + 252; + Name_Assembly : constant Name_Id := N + 253; -- The following names are preset as synonyms for C - Name_Default : constant Name_Id := N + 242; + Name_Default : constant Name_Id := N + 254; -- Name_Exernal (previously defined as pragma) -- The following names are present as synonyms for Stdcall - Name_DLL : constant Name_Id := N + 243; - Name_Win32 : constant Name_Id := N + 244; + Name_DLL : constant Name_Id := N + 255; + Name_Win32 : constant Name_Id := N + 256; -- Other special names used in processing pragmas - Name_As_Is : constant Name_Id := N + 245; - Name_Body_File_Name : constant Name_Id := N + 246; - Name_Casing : constant Name_Id := N + 247; - Name_Code : constant Name_Id := N + 248; - Name_Component : constant Name_Id := N + 249; - Name_Component_Size_4 : constant Name_Id := N + 250; - Name_Copy : constant Name_Id := N + 251; - Name_D_Float : constant Name_Id := N + 252; - Name_Descriptor : constant Name_Id := N + 253; - Name_Dot_Replacement : constant Name_Id := N + 254; - Name_Dynamic : constant Name_Id := N + 255; - Name_Entity : constant Name_Id := N + 256; - Name_External_Name : constant Name_Id := N + 257; - Name_First_Optional_Parameter : constant Name_Id := N + 258; - Name_Form : constant Name_Id := N + 259; - Name_G_Float : constant Name_Id := N + 260; - Name_Gcc : constant Name_Id := N + 261; - Name_Gnat : constant Name_Id := N + 262; - Name_GPL : constant Name_Id := N + 263; - Name_IEEE_Float : constant Name_Id := N + 264; - Name_Homonym_Number : constant Name_Id := N + 265; - Name_Internal : constant Name_Id := N + 266; - Name_Link_Name : constant Name_Id := N + 267; - Name_Lowercase : constant Name_Id := N + 268; - Name_Max_Size : constant Name_Id := N + 269; - Name_Mechanism : constant Name_Id := N + 270; - Name_Mixedcase : constant Name_Id := N + 271; - Name_Modified_GPL : constant Name_Id := N + 272; - Name_Name : constant Name_Id := N + 273; - Name_NCA : constant Name_Id := N + 274; - Name_No : constant Name_Id := N + 275; - Name_On : constant Name_Id := N + 276; - Name_Parameter_Types : constant Name_Id := N + 277; - Name_Reference : constant Name_Id := N + 278; - Name_No_Requeue : constant Name_Id := N + 279; - Name_No_Task_Attributes : constant Name_Id := N + 280; - Name_Restricted : constant Name_Id := N + 281; - Name_Result_Mechanism : constant Name_Id := N + 282; - Name_Result_Type : constant Name_Id := N + 283; - Name_Runtime : constant Name_Id := N + 284; - Name_SB : constant Name_Id := N + 285; - Name_Secondary_Stack_Size : constant Name_Id := N + 286; - Name_Section : constant Name_Id := N + 287; - Name_Semaphore : constant Name_Id := N + 288; - Name_Spec_File_Name : constant Name_Id := N + 289; - Name_Static : constant Name_Id := N + 290; - Name_Stack_Size : constant Name_Id := N + 291; - Name_Subunit_File_Name : constant Name_Id := N + 292; - Name_Task_Stack_Size_Default : constant Name_Id := N + 293; - Name_Task_Type : constant Name_Id := N + 294; - Name_Time_Slicing_Enabled : constant Name_Id := N + 295; - Name_Top_Guard : constant Name_Id := N + 296; - Name_UBA : constant Name_Id := N + 297; - Name_UBS : constant Name_Id := N + 298; - Name_UBSB : constant Name_Id := N + 299; - Name_Unit_Name : constant Name_Id := N + 300; - Name_Unknown : constant Name_Id := N + 301; - Name_Unrestricted : constant Name_Id := N + 302; - Name_Uppercase : constant Name_Id := N + 303; - Name_User : constant Name_Id := N + 304; - Name_VAX_Float : constant Name_Id := N + 305; - Name_VMS : constant Name_Id := N + 306; - Name_Working_Storage : constant Name_Id := N + 307; + Name_As_Is : constant Name_Id := N + 257; + Name_Body_File_Name : constant Name_Id := N + 258; + Name_Casing : constant Name_Id := N + 259; + Name_Code : constant Name_Id := N + 260; + Name_Component : constant Name_Id := N + 261; + Name_Component_Size_4 : constant Name_Id := N + 262; + Name_Copy : constant Name_Id := N + 263; + Name_D_Float : constant Name_Id := N + 264; + Name_Descriptor : constant Name_Id := N + 265; + Name_Dot_Replacement : constant Name_Id := N + 266; + Name_Dynamic : constant Name_Id := N + 267; + Name_Entity : constant Name_Id := N + 268; + Name_External_Name : constant Name_Id := N + 269; + Name_First_Optional_Parameter : constant Name_Id := N + 270; + Name_Form : constant Name_Id := N + 271; + Name_G_Float : constant Name_Id := N + 272; + Name_Gcc : constant Name_Id := N + 273; + Name_Gnat : constant Name_Id := N + 274; + Name_GPL : constant Name_Id := N + 275; + Name_IEEE_Float : constant Name_Id := N + 276; + Name_Homonym_Number : constant Name_Id := N + 277; + Name_Internal : constant Name_Id := N + 278; + Name_Link_Name : constant Name_Id := N + 279; + Name_Lowercase : constant Name_Id := N + 280; + Name_Max_Size : constant Name_Id := N + 281; + Name_Mechanism : constant Name_Id := N + 282; + Name_Mixedcase : constant Name_Id := N + 283; + Name_Modified_GPL : constant Name_Id := N + 284; + Name_Name : constant Name_Id := N + 285; + Name_NCA : constant Name_Id := N + 286; + Name_No : constant Name_Id := N + 287; + Name_On : constant Name_Id := N + 288; + Name_Parameter_Types : constant Name_Id := N + 289; + Name_Reference : constant Name_Id := N + 290; + Name_No_Requeue : constant Name_Id := N + 291; + Name_No_Task_Attributes : constant Name_Id := N + 292; + Name_Restricted : constant Name_Id := N + 293; + Name_Result_Mechanism : constant Name_Id := N + 294; + Name_Result_Type : constant Name_Id := N + 295; + Name_Runtime : constant Name_Id := N + 296; + Name_SB : constant Name_Id := N + 297; + Name_Secondary_Stack_Size : constant Name_Id := N + 298; + Name_Section : constant Name_Id := N + 299; + Name_Semaphore : constant Name_Id := N + 300; + Name_Spec_File_Name : constant Name_Id := N + 301; + Name_Static : constant Name_Id := N + 302; + Name_Stack_Size : constant Name_Id := N + 303; + Name_Subunit_File_Name : constant Name_Id := N + 304; + Name_Task_Stack_Size_Default : constant Name_Id := N + 305; + Name_Task_Type : constant Name_Id := N + 306; + Name_Time_Slicing_Enabled : constant Name_Id := N + 307; + Name_Top_Guard : constant Name_Id := N + 308; + Name_UBA : constant Name_Id := N + 309; + Name_UBS : constant Name_Id := N + 310; + Name_UBSB : constant Name_Id := N + 311; + Name_Unit_Name : constant Name_Id := N + 312; + Name_Unknown : constant Name_Id := N + 313; + Name_Unrestricted : constant Name_Id := N + 314; + Name_Uppercase : constant Name_Id := N + 315; + Name_User : constant Name_Id := N + 316; + Name_VAX_Float : constant Name_Id := N + 317; + Name_VMS : constant Name_Id := N + 318; + Name_Working_Storage : constant Name_Id := N + 319; -- Names of recognized attributes. The entries with the comment "Ada 83" -- are attributes that are defined in Ada 83, but not in Ada 95. These @@ -570,158 +585,158 @@ package Snames is -- The entries marked VMS are recognized only in OpenVMS implementations -- of GNAT, and are treated as illegal in all other contexts. - First_Attribute_Name : constant Name_Id := N + 308; - Name_Abort_Signal : constant Name_Id := N + 308; -- GNAT - Name_Access : constant Name_Id := N + 309; - Name_Address : constant Name_Id := N + 310; - Name_Address_Size : constant Name_Id := N + 311; -- GNAT - Name_Aft : constant Name_Id := N + 312; - Name_Alignment : constant Name_Id := N + 313; - Name_Asm_Input : constant Name_Id := N + 314; -- GNAT - Name_Asm_Output : constant Name_Id := N + 315; -- GNAT - Name_AST_Entry : constant Name_Id := N + 316; -- VMS - Name_Bit : constant Name_Id := N + 317; -- GNAT - Name_Bit_Order : constant Name_Id := N + 318; - Name_Bit_Position : constant Name_Id := N + 319; -- GNAT - Name_Body_Version : constant Name_Id := N + 320; - Name_Callable : constant Name_Id := N + 321; - Name_Caller : constant Name_Id := N + 322; - Name_Code_Address : constant Name_Id := N + 323; -- GNAT - Name_Component_Size : constant Name_Id := N + 324; - Name_Compose : constant Name_Id := N + 325; - Name_Constrained : constant Name_Id := N + 326; - Name_Count : constant Name_Id := N + 327; - Name_Default_Bit_Order : constant Name_Id := N + 328; -- GNAT - Name_Definite : constant Name_Id := N + 329; - Name_Delta : constant Name_Id := N + 330; - Name_Denorm : constant Name_Id := N + 331; - Name_Digits : constant Name_Id := N + 332; - Name_Elaborated : constant Name_Id := N + 333; -- GNAT - Name_Emax : constant Name_Id := N + 334; -- Ada 83 - Name_Enum_Rep : constant Name_Id := N + 335; -- GNAT - Name_Epsilon : constant Name_Id := N + 336; -- Ada 83 - Name_Exponent : constant Name_Id := N + 337; - Name_External_Tag : constant Name_Id := N + 338; - Name_First : constant Name_Id := N + 339; - Name_First_Bit : constant Name_Id := N + 340; - Name_Fixed_Value : constant Name_Id := N + 341; -- GNAT - Name_Fore : constant Name_Id := N + 342; - Name_Has_Discriminants : constant Name_Id := N + 343; -- GNAT - Name_Identity : constant Name_Id := N + 344; - Name_Img : constant Name_Id := N + 345; -- GNAT - Name_Integer_Value : constant Name_Id := N + 346; -- GNAT - Name_Large : constant Name_Id := N + 347; -- Ada 83 - Name_Last : constant Name_Id := N + 348; - Name_Last_Bit : constant Name_Id := N + 349; - Name_Leading_Part : constant Name_Id := N + 350; - Name_Length : constant Name_Id := N + 351; - Name_Machine_Emax : constant Name_Id := N + 352; - Name_Machine_Emin : constant Name_Id := N + 353; - Name_Machine_Mantissa : constant Name_Id := N + 354; - Name_Machine_Overflows : constant Name_Id := N + 355; - Name_Machine_Radix : constant Name_Id := N + 356; - Name_Machine_Rounds : constant Name_Id := N + 357; - Name_Machine_Size : constant Name_Id := N + 358; -- GNAT - Name_Mantissa : constant Name_Id := N + 359; -- Ada 83 - Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 360; - Name_Maximum_Alignment : constant Name_Id := N + 361; -- GNAT - Name_Mechanism_Code : constant Name_Id := N + 362; -- GNAT - Name_Model_Emin : constant Name_Id := N + 363; - Name_Model_Epsilon : constant Name_Id := N + 364; - Name_Model_Mantissa : constant Name_Id := N + 365; - Name_Model_Small : constant Name_Id := N + 366; - Name_Modulus : constant Name_Id := N + 367; - Name_Null_Parameter : constant Name_Id := N + 368; -- GNAT - Name_Object_Size : constant Name_Id := N + 369; -- GNAT - Name_Partition_ID : constant Name_Id := N + 370; - Name_Passed_By_Reference : constant Name_Id := N + 371; -- GNAT - Name_Pool_Address : constant Name_Id := N + 372; - Name_Pos : constant Name_Id := N + 373; - Name_Position : constant Name_Id := N + 374; - Name_Range : constant Name_Id := N + 375; - Name_Range_Length : constant Name_Id := N + 376; -- GNAT - Name_Round : constant Name_Id := N + 377; - Name_Safe_Emax : constant Name_Id := N + 378; -- Ada 83 - Name_Safe_First : constant Name_Id := N + 379; - Name_Safe_Large : constant Name_Id := N + 380; -- Ada 83 - Name_Safe_Last : constant Name_Id := N + 381; - Name_Safe_Small : constant Name_Id := N + 382; -- Ada 83 - Name_Scale : constant Name_Id := N + 383; - Name_Scaling : constant Name_Id := N + 384; - Name_Signed_Zeros : constant Name_Id := N + 385; - Name_Size : constant Name_Id := N + 386; - Name_Small : constant Name_Id := N + 387; - Name_Storage_Size : constant Name_Id := N + 388; - Name_Storage_Unit : constant Name_Id := N + 389; -- GNAT - Name_Tag : constant Name_Id := N + 390; - Name_Target_Name : constant Name_Id := N + 391; -- GNAT - Name_Terminated : constant Name_Id := N + 392; - Name_To_Address : constant Name_Id := N + 393; -- GNAT - Name_Type_Class : constant Name_Id := N + 394; -- GNAT - Name_UET_Address : constant Name_Id := N + 395; -- GNAT - Name_Unbiased_Rounding : constant Name_Id := N + 396; - Name_Unchecked_Access : constant Name_Id := N + 397; - Name_Unconstrained_Array : constant Name_Id := N + 398; - Name_Universal_Literal_String : constant Name_Id := N + 399; -- GNAT - Name_Unrestricted_Access : constant Name_Id := N + 400; -- GNAT - Name_VADS_Size : constant Name_Id := N + 401; -- GNAT - Name_Val : constant Name_Id := N + 402; - Name_Valid : constant Name_Id := N + 403; - Name_Value_Size : constant Name_Id := N + 404; -- GNAT - Name_Version : constant Name_Id := N + 405; - Name_Wchar_T_Size : constant Name_Id := N + 406; -- GNAT - Name_Wide_Width : constant Name_Id := N + 407; - Name_Width : constant Name_Id := N + 408; - Name_Word_Size : constant Name_Id := N + 409; -- GNAT + First_Attribute_Name : constant Name_Id := N + 320; + Name_Abort_Signal : constant Name_Id := N + 320; -- GNAT + Name_Access : constant Name_Id := N + 321; + Name_Address : constant Name_Id := N + 322; + Name_Address_Size : constant Name_Id := N + 323; -- GNAT + Name_Aft : constant Name_Id := N + 324; + Name_Alignment : constant Name_Id := N + 325; + Name_Asm_Input : constant Name_Id := N + 326; -- GNAT + Name_Asm_Output : constant Name_Id := N + 327; -- GNAT + Name_AST_Entry : constant Name_Id := N + 328; -- VMS + Name_Bit : constant Name_Id := N + 329; -- GNAT + Name_Bit_Order : constant Name_Id := N + 330; + Name_Bit_Position : constant Name_Id := N + 331; -- GNAT + Name_Body_Version : constant Name_Id := N + 332; + Name_Callable : constant Name_Id := N + 333; + Name_Caller : constant Name_Id := N + 334; + Name_Code_Address : constant Name_Id := N + 335; -- GNAT + Name_Component_Size : constant Name_Id := N + 336; + Name_Compose : constant Name_Id := N + 337; + Name_Constrained : constant Name_Id := N + 338; + Name_Count : constant Name_Id := N + 339; + Name_Default_Bit_Order : constant Name_Id := N + 340; -- GNAT + Name_Definite : constant Name_Id := N + 341; + Name_Delta : constant Name_Id := N + 342; + Name_Denorm : constant Name_Id := N + 343; + Name_Digits : constant Name_Id := N + 344; + Name_Elaborated : constant Name_Id := N + 345; -- GNAT + Name_Emax : constant Name_Id := N + 346; -- Ada 83 + Name_Enum_Rep : constant Name_Id := N + 347; -- GNAT + Name_Epsilon : constant Name_Id := N + 348; -- Ada 83 + Name_Exponent : constant Name_Id := N + 349; + Name_External_Tag : constant Name_Id := N + 350; + Name_First : constant Name_Id := N + 351; + Name_First_Bit : constant Name_Id := N + 352; + Name_Fixed_Value : constant Name_Id := N + 353; -- GNAT + Name_Fore : constant Name_Id := N + 354; + Name_Has_Discriminants : constant Name_Id := N + 355; -- GNAT + Name_Identity : constant Name_Id := N + 356; + Name_Img : constant Name_Id := N + 357; -- GNAT + Name_Integer_Value : constant Name_Id := N + 358; -- GNAT + Name_Large : constant Name_Id := N + 359; -- Ada 83 + Name_Last : constant Name_Id := N + 360; + Name_Last_Bit : constant Name_Id := N + 361; + Name_Leading_Part : constant Name_Id := N + 362; + Name_Length : constant Name_Id := N + 363; + Name_Machine_Emax : constant Name_Id := N + 364; + Name_Machine_Emin : constant Name_Id := N + 365; + Name_Machine_Mantissa : constant Name_Id := N + 366; + Name_Machine_Overflows : constant Name_Id := N + 367; + Name_Machine_Radix : constant Name_Id := N + 368; + Name_Machine_Rounds : constant Name_Id := N + 369; + Name_Machine_Size : constant Name_Id := N + 370; -- GNAT + Name_Mantissa : constant Name_Id := N + 371; -- Ada 83 + Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 372; + Name_Maximum_Alignment : constant Name_Id := N + 373; -- GNAT + Name_Mechanism_Code : constant Name_Id := N + 374; -- GNAT + Name_Model_Emin : constant Name_Id := N + 375; + Name_Model_Epsilon : constant Name_Id := N + 376; + Name_Model_Mantissa : constant Name_Id := N + 377; + Name_Model_Small : constant Name_Id := N + 378; + Name_Modulus : constant Name_Id := N + 379; + Name_Null_Parameter : constant Name_Id := N + 380; -- GNAT + Name_Object_Size : constant Name_Id := N + 381; -- GNAT + Name_Partition_ID : constant Name_Id := N + 382; + Name_Passed_By_Reference : constant Name_Id := N + 383; -- GNAT + Name_Pool_Address : constant Name_Id := N + 384; + Name_Pos : constant Name_Id := N + 385; + Name_Position : constant Name_Id := N + 386; + Name_Range : constant Name_Id := N + 387; + Name_Range_Length : constant Name_Id := N + 388; -- GNAT + Name_Round : constant Name_Id := N + 389; + Name_Safe_Emax : constant Name_Id := N + 390; -- Ada 83 + Name_Safe_First : constant Name_Id := N + 391; + Name_Safe_Large : constant Name_Id := N + 392; -- Ada 83 + Name_Safe_Last : constant Name_Id := N + 393; + Name_Safe_Small : constant Name_Id := N + 394; -- Ada 83 + Name_Scale : constant Name_Id := N + 395; + Name_Scaling : constant Name_Id := N + 396; + Name_Signed_Zeros : constant Name_Id := N + 397; + Name_Size : constant Name_Id := N + 398; + Name_Small : constant Name_Id := N + 399; + Name_Storage_Size : constant Name_Id := N + 400; + Name_Storage_Unit : constant Name_Id := N + 401; -- GNAT + Name_Tag : constant Name_Id := N + 402; + Name_Target_Name : constant Name_Id := N + 403; -- GNAT + Name_Terminated : constant Name_Id := N + 404; + Name_To_Address : constant Name_Id := N + 405; -- GNAT + Name_Type_Class : constant Name_Id := N + 406; -- GNAT + Name_UET_Address : constant Name_Id := N + 407; -- GNAT + Name_Unbiased_Rounding : constant Name_Id := N + 408; + Name_Unchecked_Access : constant Name_Id := N + 409; + Name_Unconstrained_Array : constant Name_Id := N + 410; + Name_Universal_Literal_String : constant Name_Id := N + 411; -- GNAT + Name_Unrestricted_Access : constant Name_Id := N + 412; -- GNAT + Name_VADS_Size : constant Name_Id := N + 413; -- GNAT + Name_Val : constant Name_Id := N + 414; + Name_Valid : constant Name_Id := N + 415; + Name_Value_Size : constant Name_Id := N + 416; -- GNAT + Name_Version : constant Name_Id := N + 417; + Name_Wchar_T_Size : constant Name_Id := N + 418; -- GNAT + Name_Wide_Width : constant Name_Id := N + 419; + Name_Width : constant Name_Id := N + 420; + Name_Word_Size : constant Name_Id := N + 421; -- GNAT -- Attributes that designate attributes returning renamable functions, -- i.e. functions that return other than a universal value. - First_Renamable_Function_Attribute : constant Name_Id := N + 410; - Name_Adjacent : constant Name_Id := N + 410; - Name_Ceiling : constant Name_Id := N + 411; - Name_Copy_Sign : constant Name_Id := N + 412; - Name_Floor : constant Name_Id := N + 413; - Name_Fraction : constant Name_Id := N + 414; - Name_Image : constant Name_Id := N + 415; - Name_Input : constant Name_Id := N + 416; - Name_Machine : constant Name_Id := N + 417; - Name_Max : constant Name_Id := N + 418; - Name_Min : constant Name_Id := N + 419; - Name_Model : constant Name_Id := N + 420; - Name_Pred : constant Name_Id := N + 421; - Name_Remainder : constant Name_Id := N + 422; - Name_Rounding : constant Name_Id := N + 423; - Name_Succ : constant Name_Id := N + 424; - Name_Truncation : constant Name_Id := N + 425; - Name_Value : constant Name_Id := N + 426; - Name_Wide_Image : constant Name_Id := N + 427; - Name_Wide_Value : constant Name_Id := N + 428; - Last_Renamable_Function_Attribute : constant Name_Id := N + 428; + First_Renamable_Function_Attribute : constant Name_Id := N + 422; + Name_Adjacent : constant Name_Id := N + 422; + Name_Ceiling : constant Name_Id := N + 423; + Name_Copy_Sign : constant Name_Id := N + 424; + Name_Floor : constant Name_Id := N + 425; + Name_Fraction : constant Name_Id := N + 426; + Name_Image : constant Name_Id := N + 427; + Name_Input : constant Name_Id := N + 428; + Name_Machine : constant Name_Id := N + 429; + Name_Max : constant Name_Id := N + 430; + Name_Min : constant Name_Id := N + 431; + Name_Model : constant Name_Id := N + 432; + Name_Pred : constant Name_Id := N + 433; + Name_Remainder : constant Name_Id := N + 434; + Name_Rounding : constant Name_Id := N + 435; + Name_Succ : constant Name_Id := N + 436; + Name_Truncation : constant Name_Id := N + 437; + Name_Value : constant Name_Id := N + 438; + Name_Wide_Image : constant Name_Id := N + 439; + Name_Wide_Value : constant Name_Id := N + 440; + Last_Renamable_Function_Attribute : constant Name_Id := N + 440; -- Attributes that designate procedures - First_Procedure_Attribute : constant Name_Id := N + 429; - Name_Output : constant Name_Id := N + 429; - Name_Read : constant Name_Id := N + 430; - Name_Write : constant Name_Id := N + 431; - Last_Procedure_Attribute : constant Name_Id := N + 431; + First_Procedure_Attribute : constant Name_Id := N + 441; + Name_Output : constant Name_Id := N + 441; + Name_Read : constant Name_Id := N + 442; + Name_Write : constant Name_Id := N + 443; + Last_Procedure_Attribute : constant Name_Id := N + 443; -- Remaining attributes are ones that return entities - First_Entity_Attribute_Name : constant Name_Id := N + 432; - Name_Elab_Body : constant Name_Id := N + 432; -- GNAT - Name_Elab_Spec : constant Name_Id := N + 433; -- GNAT - Name_Storage_Pool : constant Name_Id := N + 434; + First_Entity_Attribute_Name : constant Name_Id := N + 444; + Name_Elab_Body : constant Name_Id := N + 444; -- GNAT + Name_Elab_Spec : constant Name_Id := N + 445; -- GNAT + Name_Storage_Pool : constant Name_Id := N + 446; -- These attributes are the ones that return types - First_Type_Attribute_Name : constant Name_Id := N + 435; - Name_Base : constant Name_Id := N + 435; - Name_Class : constant Name_Id := N + 436; - Last_Type_Attribute_Name : constant Name_Id := N + 436; - Last_Entity_Attribute_Name : constant Name_Id := N + 436; - Last_Attribute_Name : constant Name_Id := N + 436; + First_Type_Attribute_Name : constant Name_Id := N + 447; + Name_Base : constant Name_Id := N + 447; + Name_Class : constant Name_Id := N + 448; + Last_Type_Attribute_Name : constant Name_Id := N + 448; + Last_Entity_Attribute_Name : constant Name_Id := N + 448; + Last_Attribute_Name : constant Name_Id := N + 448; -- Names of recognized locking policy identifiers @@ -729,10 +744,10 @@ package Snames is -- name (e.g. C for Ceiling_Locking). If new policy names are added, -- the first character must be distinct. - First_Locking_Policy_Name : constant Name_Id := N + 437; - Name_Ceiling_Locking : constant Name_Id := N + 437; - Name_Inheritance_Locking : constant Name_Id := N + 438; - Last_Locking_Policy_Name : constant Name_Id := N + 438; + First_Locking_Policy_Name : constant Name_Id := N + 449; + Name_Ceiling_Locking : constant Name_Id := N + 449; + Name_Inheritance_Locking : constant Name_Id := N + 450; + Last_Locking_Policy_Name : constant Name_Id := N + 450; -- Names of recognized queuing policy identifiers. @@ -740,10 +755,10 @@ package Snames is -- name (e.g. F for FIFO_Queuing). If new policy names are added, -- the first character must be distinct. - First_Queuing_Policy_Name : constant Name_Id := N + 439; - Name_FIFO_Queuing : constant Name_Id := N + 439; - Name_Priority_Queuing : constant Name_Id := N + 440; - Last_Queuing_Policy_Name : constant Name_Id := N + 440; + First_Queuing_Policy_Name : constant Name_Id := N + 451; + Name_FIFO_Queuing : constant Name_Id := N + 451; + Name_Priority_Queuing : constant Name_Id := N + 452; + Last_Queuing_Policy_Name : constant Name_Id := N + 452; -- Names of recognized task dispatching policy identifiers @@ -751,193 +766,193 @@ package Snames is -- name (e.g. F for FIFO_WIthinn_Priorities). If new policy names -- are added, the first character must be distinct. - First_Task_Dispatching_Policy_Name : constant Name_Id := N + 441; - Name_FIFO_Within_Priorities : constant Name_Id := N + 441; - Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 441; + First_Task_Dispatching_Policy_Name : constant Name_Id := N + 453; + Name_FIFO_Within_Priorities : constant Name_Id := N + 453; + Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 453; -- Names of recognized checks for pragma Suppress - First_Check_Name : constant Name_Id := N + 442; - Name_Access_Check : constant Name_Id := N + 442; - Name_Accessibility_Check : constant Name_Id := N + 443; - Name_Discriminant_Check : constant Name_Id := N + 444; - Name_Division_Check : constant Name_Id := N + 445; - Name_Elaboration_Check : constant Name_Id := N + 446; - Name_Index_Check : constant Name_Id := N + 447; - Name_Length_Check : constant Name_Id := N + 448; - Name_Overflow_Check : constant Name_Id := N + 449; - Name_Range_Check : constant Name_Id := N + 450; - Name_Storage_Check : constant Name_Id := N + 451; - Name_Tag_Check : constant Name_Id := N + 452; - Name_All_Checks : constant Name_Id := N + 453; - Last_Check_Name : constant Name_Id := N + 453; + First_Check_Name : constant Name_Id := N + 454; + Name_Access_Check : constant Name_Id := N + 454; + Name_Accessibility_Check : constant Name_Id := N + 455; + Name_Discriminant_Check : constant Name_Id := N + 456; + Name_Division_Check : constant Name_Id := N + 457; + Name_Elaboration_Check : constant Name_Id := N + 458; + Name_Index_Check : constant Name_Id := N + 459; + Name_Length_Check : constant Name_Id := N + 460; + Name_Overflow_Check : constant Name_Id := N + 461; + Name_Range_Check : constant Name_Id := N + 462; + Name_Storage_Check : constant Name_Id := N + 463; + Name_Tag_Check : constant Name_Id := N + 464; + Name_All_Checks : constant Name_Id := N + 465; + Last_Check_Name : constant Name_Id := N + 465; -- Names corresponding to reserved keywords, excluding those already -- declared in the attribute list (Access, Delta, Digits, Range). - Name_Abort : constant Name_Id := N + 454; - Name_Abs : constant Name_Id := N + 455; - Name_Accept : constant Name_Id := N + 456; - Name_And : constant Name_Id := N + 457; - Name_All : constant Name_Id := N + 458; - Name_Array : constant Name_Id := N + 459; - Name_At : constant Name_Id := N + 460; - Name_Begin : constant Name_Id := N + 461; - Name_Body : constant Name_Id := N + 462; - Name_Case : constant Name_Id := N + 463; - Name_Constant : constant Name_Id := N + 464; - Name_Declare : constant Name_Id := N + 465; - Name_Delay : constant Name_Id := N + 466; - Name_Do : constant Name_Id := N + 467; - Name_Else : constant Name_Id := N + 468; - Name_Elsif : constant Name_Id := N + 469; - Name_End : constant Name_Id := N + 470; - Name_Entry : constant Name_Id := N + 471; - Name_Exception : constant Name_Id := N + 472; - Name_Exit : constant Name_Id := N + 473; - Name_For : constant Name_Id := N + 474; - Name_Function : constant Name_Id := N + 475; - Name_Generic : constant Name_Id := N + 476; - Name_Goto : constant Name_Id := N + 477; - Name_If : constant Name_Id := N + 478; - Name_In : constant Name_Id := N + 479; - Name_Is : constant Name_Id := N + 480; - Name_Limited : constant Name_Id := N + 481; - Name_Loop : constant Name_Id := N + 482; - Name_Mod : constant Name_Id := N + 483; - Name_New : constant Name_Id := N + 484; - Name_Not : constant Name_Id := N + 485; - Name_Null : constant Name_Id := N + 486; - Name_Of : constant Name_Id := N + 487; - Name_Or : constant Name_Id := N + 488; - Name_Others : constant Name_Id := N + 489; - Name_Out : constant Name_Id := N + 490; - Name_Package : constant Name_Id := N + 491; - Name_Pragma : constant Name_Id := N + 492; - Name_Private : constant Name_Id := N + 493; - Name_Procedure : constant Name_Id := N + 494; - Name_Raise : constant Name_Id := N + 495; - Name_Record : constant Name_Id := N + 496; - Name_Rem : constant Name_Id := N + 497; - Name_Renames : constant Name_Id := N + 498; - Name_Return : constant Name_Id := N + 499; - Name_Reverse : constant Name_Id := N + 500; - Name_Select : constant Name_Id := N + 501; - Name_Separate : constant Name_Id := N + 502; - Name_Subtype : constant Name_Id := N + 503; - Name_Task : constant Name_Id := N + 504; - Name_Terminate : constant Name_Id := N + 505; - Name_Then : constant Name_Id := N + 506; - Name_Type : constant Name_Id := N + 507; - Name_Use : constant Name_Id := N + 508; - Name_When : constant Name_Id := N + 509; - Name_While : constant Name_Id := N + 510; - Name_With : constant Name_Id := N + 511; - Name_Xor : constant Name_Id := N + 512; + Name_Abort : constant Name_Id := N + 466; + Name_Abs : constant Name_Id := N + 467; + Name_Accept : constant Name_Id := N + 468; + Name_And : constant Name_Id := N + 469; + Name_All : constant Name_Id := N + 470; + Name_Array : constant Name_Id := N + 471; + Name_At : constant Name_Id := N + 472; + Name_Begin : constant Name_Id := N + 473; + Name_Body : constant Name_Id := N + 474; + Name_Case : constant Name_Id := N + 475; + Name_Constant : constant Name_Id := N + 476; + Name_Declare : constant Name_Id := N + 477; + Name_Delay : constant Name_Id := N + 478; + Name_Do : constant Name_Id := N + 479; + Name_Else : constant Name_Id := N + 480; + Name_Elsif : constant Name_Id := N + 481; + Name_End : constant Name_Id := N + 482; + Name_Entry : constant Name_Id := N + 483; + Name_Exception : constant Name_Id := N + 484; + Name_Exit : constant Name_Id := N + 485; + Name_For : constant Name_Id := N + 486; + Name_Function : constant Name_Id := N + 487; + Name_Generic : constant Name_Id := N + 488; + Name_Goto : constant Name_Id := N + 489; + Name_If : constant Name_Id := N + 490; + Name_In : constant Name_Id := N + 491; + Name_Is : constant Name_Id := N + 492; + Name_Limited : constant Name_Id := N + 493; + Name_Loop : constant Name_Id := N + 494; + Name_Mod : constant Name_Id := N + 495; + Name_New : constant Name_Id := N + 496; + Name_Not : constant Name_Id := N + 497; + Name_Null : constant Name_Id := N + 498; + Name_Of : constant Name_Id := N + 499; + Name_Or : constant Name_Id := N + 500; + Name_Others : constant Name_Id := N + 501; + Name_Out : constant Name_Id := N + 502; + Name_Package : constant Name_Id := N + 503; + Name_Pragma : constant Name_Id := N + 504; + Name_Private : constant Name_Id := N + 505; + Name_Procedure : constant Name_Id := N + 506; + Name_Raise : constant Name_Id := N + 507; + Name_Record : constant Name_Id := N + 508; + Name_Rem : constant Name_Id := N + 509; + Name_Renames : constant Name_Id := N + 510; + Name_Return : constant Name_Id := N + 511; + Name_Reverse : constant Name_Id := N + 512; + Name_Select : constant Name_Id := N + 513; + Name_Separate : constant Name_Id := N + 514; + Name_Subtype : constant Name_Id := N + 515; + Name_Task : constant Name_Id := N + 516; + Name_Terminate : constant Name_Id := N + 517; + Name_Then : constant Name_Id := N + 518; + Name_Type : constant Name_Id := N + 519; + Name_Use : constant Name_Id := N + 520; + Name_When : constant Name_Id := N + 521; + Name_While : constant Name_Id := N + 522; + Name_With : constant Name_Id := N + 523; + Name_Xor : constant Name_Id := N + 524; -- Names of intrinsic subprograms -- Note: Asm is missing from this list, since Asm is a legitimate -- convention name. So is To_Adress, which is a GNAT attribute. - First_Intrinsic_Name : constant Name_Id := N + 513; - Name_Divide : constant Name_Id := N + 513; - Name_Enclosing_Entity : constant Name_Id := N + 514; - Name_Exception_Information : constant Name_Id := N + 515; - Name_Exception_Message : constant Name_Id := N + 516; - Name_Exception_Name : constant Name_Id := N + 517; - Name_File : constant Name_Id := N + 518; - Name_Import_Address : constant Name_Id := N + 519; - Name_Import_Largest_Value : constant Name_Id := N + 520; - Name_Import_Value : constant Name_Id := N + 521; - Name_Is_Negative : constant Name_Id := N + 522; - Name_Line : constant Name_Id := N + 523; - Name_Rotate_Left : constant Name_Id := N + 524; - Name_Rotate_Right : constant Name_Id := N + 525; - Name_Shift_Left : constant Name_Id := N + 526; - Name_Shift_Right : constant Name_Id := N + 527; - Name_Shift_Right_Arithmetic : constant Name_Id := N + 528; - Name_Source_Location : constant Name_Id := N + 529; - Name_Unchecked_Conversion : constant Name_Id := N + 530; - Name_Unchecked_Deallocation : constant Name_Id := N + 531; - Name_To_Pointer : constant Name_Id := N + 532; - Last_Intrinsic_Name : constant Name_Id := N + 532; + First_Intrinsic_Name : constant Name_Id := N + 525; + Name_Divide : constant Name_Id := N + 525; + Name_Enclosing_Entity : constant Name_Id := N + 526; + Name_Exception_Information : constant Name_Id := N + 527; + Name_Exception_Message : constant Name_Id := N + 528; + Name_Exception_Name : constant Name_Id := N + 529; + Name_File : constant Name_Id := N + 530; + Name_Import_Address : constant Name_Id := N + 531; + Name_Import_Largest_Value : constant Name_Id := N + 532; + Name_Import_Value : constant Name_Id := N + 533; + Name_Is_Negative : constant Name_Id := N + 534; + Name_Line : constant Name_Id := N + 535; + Name_Rotate_Left : constant Name_Id := N + 536; + Name_Rotate_Right : constant Name_Id := N + 537; + Name_Shift_Left : constant Name_Id := N + 538; + Name_Shift_Right : constant Name_Id := N + 539; + Name_Shift_Right_Arithmetic : constant Name_Id := N + 540; + Name_Source_Location : constant Name_Id := N + 541; + Name_Unchecked_Conversion : constant Name_Id := N + 542; + Name_Unchecked_Deallocation : constant Name_Id := N + 543; + Name_To_Pointer : constant Name_Id := N + 544; + Last_Intrinsic_Name : constant Name_Id := N + 544; -- Reserved words used only in Ada 95 - First_95_Reserved_Word : constant Name_Id := N + 533; - Name_Abstract : constant Name_Id := N + 533; - Name_Aliased : constant Name_Id := N + 534; - Name_Protected : constant Name_Id := N + 535; - Name_Until : constant Name_Id := N + 536; - Name_Requeue : constant Name_Id := N + 537; - Name_Tagged : constant Name_Id := N + 538; - Last_95_Reserved_Word : constant Name_Id := N + 538; + First_95_Reserved_Word : constant Name_Id := N + 545; + Name_Abstract : constant Name_Id := N + 545; + Name_Aliased : constant Name_Id := N + 546; + Name_Protected : constant Name_Id := N + 547; + Name_Until : constant Name_Id := N + 548; + Name_Requeue : constant Name_Id := N + 549; + Name_Tagged : constant Name_Id := N + 550; + Last_95_Reserved_Word : constant Name_Id := N + 550; subtype Ada_95_Reserved_Words is Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word; -- Miscellaneous names used in semantic checking - Name_Raise_Exception : constant Name_Id := N + 539; + Name_Raise_Exception : constant Name_Id := N + 551; -- Additional reserved words in GNAT Project Files -- Note that Name_External is already previously declared - Name_Binder : constant Name_Id := N + 540; - Name_Body_Suffix : constant Name_Id := N + 541; - Name_Builder : constant Name_Id := N + 542; - Name_Compiler : constant Name_Id := N + 543; - Name_Cross_Reference : constant Name_Id := N + 544; - Name_Default_Switches : constant Name_Id := N + 545; - Name_Exec_Dir : constant Name_Id := N + 546; - Name_Executable : constant Name_Id := N + 547; - Name_Executable_Suffix : constant Name_Id := N + 548; - Name_Extends : constant Name_Id := N + 549; - Name_Finder : constant Name_Id := N + 550; - Name_Global_Configuration_Pragmas : constant Name_Id := N + 551; - Name_Gnatls : constant Name_Id := N + 552; - Name_Gnatstub : constant Name_Id := N + 553; - Name_Implementation : constant Name_Id := N + 554; - Name_Implementation_Exceptions : constant Name_Id := N + 555; - Name_Implementation_Suffix : constant Name_Id := N + 556; - Name_Languages : constant Name_Id := N + 557; - Name_Library_Dir : constant Name_Id := N + 558; - Name_Library_Auto_Init : constant Name_Id := N + 559; - Name_Library_GCC : constant Name_Id := N + 560; - Name_Library_Interface : constant Name_Id := N + 561; - Name_Library_Kind : constant Name_Id := N + 562; - Name_Library_Name : constant Name_Id := N + 563; - Name_Library_Options : constant Name_Id := N + 564; - Name_Library_Reference_Symbol_File : constant Name_Id := N + 565; - Name_Library_Src_Dir : constant Name_Id := N + 566; - Name_Library_Symbol_File : constant Name_Id := N + 567; - Name_Library_Symbol_Policy : constant Name_Id := N + 568; - Name_Library_Version : constant Name_Id := N + 569; - Name_Linker : constant Name_Id := N + 570; - Name_Local_Configuration_Pragmas : constant Name_Id := N + 571; - Name_Locally_Removed_Files : constant Name_Id := N + 572; - Name_Naming : constant Name_Id := N + 573; - Name_Object_Dir : constant Name_Id := N + 574; - Name_Pretty_Printer : constant Name_Id := N + 575; - Name_Project : constant Name_Id := N + 576; - Name_Separate_Suffix : constant Name_Id := N + 577; - Name_Source_Dirs : constant Name_Id := N + 578; - Name_Source_Files : constant Name_Id := N + 579; - Name_Source_List_File : constant Name_Id := N + 580; - Name_Spec : constant Name_Id := N + 581; - Name_Spec_Suffix : constant Name_Id := N + 582; - Name_Specification : constant Name_Id := N + 583; - Name_Specification_Exceptions : constant Name_Id := N + 584; - Name_Specification_Suffix : constant Name_Id := N + 585; - Name_Switches : constant Name_Id := N + 586; + Name_Binder : constant Name_Id := N + 552; + Name_Body_Suffix : constant Name_Id := N + 553; + Name_Builder : constant Name_Id := N + 554; + Name_Compiler : constant Name_Id := N + 555; + Name_Cross_Reference : constant Name_Id := N + 556; + Name_Default_Switches : constant Name_Id := N + 557; + Name_Exec_Dir : constant Name_Id := N + 558; + Name_Executable : constant Name_Id := N + 559; + Name_Executable_Suffix : constant Name_Id := N + 560; + Name_Extends : constant Name_Id := N + 561; + Name_Finder : constant Name_Id := N + 562; + Name_Global_Configuration_Pragmas : constant Name_Id := N + 563; + Name_Gnatls : constant Name_Id := N + 564; + Name_Gnatstub : constant Name_Id := N + 565; + Name_Implementation : constant Name_Id := N + 566; + Name_Implementation_Exceptions : constant Name_Id := N + 567; + Name_Implementation_Suffix : constant Name_Id := N + 568; + Name_Languages : constant Name_Id := N + 569; + Name_Library_Dir : constant Name_Id := N + 570; + Name_Library_Auto_Init : constant Name_Id := N + 571; + Name_Library_GCC : constant Name_Id := N + 572; + Name_Library_Interface : constant Name_Id := N + 573; + Name_Library_Kind : constant Name_Id := N + 574; + Name_Library_Name : constant Name_Id := N + 575; + Name_Library_Options : constant Name_Id := N + 576; + Name_Library_Reference_Symbol_File : constant Name_Id := N + 577; + Name_Library_Src_Dir : constant Name_Id := N + 578; + Name_Library_Symbol_File : constant Name_Id := N + 579; + Name_Library_Symbol_Policy : constant Name_Id := N + 580; + Name_Library_Version : constant Name_Id := N + 581; + Name_Linker : constant Name_Id := N + 582; + Name_Local_Configuration_Pragmas : constant Name_Id := N + 583; + Name_Locally_Removed_Files : constant Name_Id := N + 584; + Name_Naming : constant Name_Id := N + 585; + Name_Object_Dir : constant Name_Id := N + 586; + Name_Pretty_Printer : constant Name_Id := N + 587; + Name_Project : constant Name_Id := N + 588; + Name_Separate_Suffix : constant Name_Id := N + 589; + Name_Source_Dirs : constant Name_Id := N + 590; + Name_Source_Files : constant Name_Id := N + 591; + Name_Source_List_File : constant Name_Id := N + 592; + Name_Spec : constant Name_Id := N + 593; + Name_Spec_Suffix : constant Name_Id := N + 594; + Name_Specification : constant Name_Id := N + 595; + Name_Specification_Exceptions : constant Name_Id := N + 596; + Name_Specification_Suffix : constant Name_Id := N + 597; + Name_Switches : constant Name_Id := N + 598; -- Other miscellaneous names used in front end - Name_Unaligned_Valid : constant Name_Id := N + 587; + Name_Unaligned_Valid : constant Name_Id := N + 599; -- Mark last defined name for consistency check in Snames body - Last_Predefined_Name : constant Name_Id := N + 587; + Last_Predefined_Name : constant Name_Id := N + 599; subtype Any_Operator_Name is Name_Id range First_Operator_Name .. Last_Operator_Name; diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 8c93670..57b2fe0 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -693,14 +693,27 @@ package body Sprint is when N_Access_Definition => - -- Ada 0Y (AI-231) + -- Ada 0Y (AI-254) - if Null_Exclusion_Present (Node) then - Write_Str ("not null "); - end if; + if Present (Access_To_Subprogram_Definition (Node)) then + Sprint_Node (Access_To_Subprogram_Definition (Node)); + else + -- Ada 0Y (AI-231) - Write_Str_With_Col_Check_Sloc ("access "); - Sprint_Node (Subtype_Mark (Node)); + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + + Write_Str_With_Col_Check_Sloc ("access "); + + if All_Present (Node) then + Write_Str ("all "); + elsif Constant_Present (Node) then + Write_Str ("constant "); + end if; + + Sprint_Node (Subtype_Mark (Node)); + end if; when N_Access_Function_Definition => diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb index 4001ba8..03124a1 100644 --- a/gcc/ada/switch-m.adb +++ b/gcc/ada/switch-m.adb @@ -551,6 +551,27 @@ package body Switch.M is return; + -- Processing for e switch + + when 'e' => + Ptr := Ptr + 1; + + if Ptr > Max then + raise Bad_Switch; + end if; + + case Switch_Chars (Ptr) is + + -- processing for eL switch + + when 'L' => + Ptr := Ptr + 1; + Follow_Links := True; + + when others => + raise Bad_Switch; + end case; + -- Processing for f switch when 'f' => diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index 8b24761..9c5b3f5 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -2073,10 +2073,6 @@ tree_transform (Node_Id gnat_node) case N_Label: gnu_result = build_nt (LABEL_STMT, gnat_to_gnu (Identifier (gnat_node))); - LABEL_STMT_FIRST_IN_EH (gnu_result) - = (Present (Parent (gnat_node)) - && Nkind (Parent (gnat_node)) == N_Exception_Handler - && First (Statements (Parent (gnat_node))) == gnat_node); break; case N_Null_Statement: @@ -2649,6 +2645,9 @@ tree_transform (Node_Id gnat_node) gnu_subprog_type = TREE_TYPE (gnu_subprog_decl); + /* ??? Temporarily do this to avoid GC throwing away outer stuff. */ + ggc_push_context (); + /* Set the line number in the decl to correspond to that of the body so that the line number notes are written correctly. */ @@ -2769,15 +2768,12 @@ tree_transform (Node_Id gnat_node) mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node))); write_symbols = save_write_symbols; debug_hooks = save_debug_hooks; + ggc_pop_context (); } break; case N_Function_Call: case N_Procedure_Call_Statement: - - if (type_annotate_only) - break; - { /* The GCC node corresponding to the GNAT subprogram name. This can either be a FUNCTION_DECL node if we are dealing with a standard @@ -2792,6 +2788,7 @@ tree_transform (Node_Id gnat_node) Node_Id gnat_actual; tree gnu_actual_list = NULL_TREE; tree gnu_name_list = NULL_TREE; + tree gnu_before_list = NULL_TREE; tree gnu_after_list = NULL_TREE; tree gnu_subprog_call; @@ -2827,8 +2824,9 @@ tree_transform (Node_Id gnat_node) build_call_raise (PE_Stubbed_Subprogram_Called)); } else - expand_expr_stmt - (build_call_raise (PE_Stubbed_Subprogram_Called)); + gnu_result + = build_nt (EXPR_STMT, + build_call_raise (PE_Stubbed_Subprogram_Called)); break; } @@ -2920,10 +2918,15 @@ tree_transform (Node_Id gnat_node) } /* Set up to move the copy back to the original. */ - gnu_after_list = tree_cons (gnu_copy, gnu_actual, - gnu_after_list); - - gnu_name = gnu_actual; + gnu_temp + = build_nt (EXPR_STMT, + build (MODIFY_EXPR, TREE_TYPE (gnu_copy), + gnu_copy, gnu_actual)); + + TREE_TYPE (gnu_temp) = void_type_node; + TREE_SLOC (gnu_temp) = Sloc (gnat_actual); + TREE_CHAIN (gnu_temp) = gnu_after_list; + gnu_after_list = gnu_temp; } } @@ -3115,6 +3118,7 @@ tree_transform (Node_Id gnat_node) gnu_result); gnu_result_type = get_unpadded_type (Etype (gnat_node)); + break; } /* If this is the case where the GNAT tree contains a procedure call @@ -3218,26 +3222,29 @@ tree_transform (Node_Id gnat_node) gnu_result); } - set_lineno (gnat_node, 1); - expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, - gnu_actual, gnu_result)); + gnu_result + = build_nt (EXPR_STMT, + build_binary_op (MODIFY_EXPR, NULL_TREE, + gnu_actual, gnu_result)); + TREE_TYPE (gnu_result) = void_type_node; + TREE_SLOC (gnu_result) = Sloc (gnat_actual); + TREE_CHAIN (gnu_result) = gnu_before_list; + gnu_before_list = gnu_result; scalar_return_list = TREE_CHAIN (scalar_return_list); gnu_name_list = TREE_CHAIN (gnu_name_list); } } else { - set_lineno (gnat_node, 1); - expand_expr_stmt (gnu_subprog_call); + gnu_before_list = build_nt (EXPR_STMT, gnu_subprog_call); + TREE_TYPE (gnu_before_list) = void_type_node; + TREE_SLOC (gnu_before_list) = Sloc (gnat_node); } - /* Handle anything we need to assign back. */ - for (gnu_expr = gnu_after_list; - gnu_expr; - gnu_expr = TREE_CHAIN (gnu_expr)) - expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, - TREE_PURPOSE (gnu_expr), - TREE_VALUE (gnu_expr))); + gnu_result = chainon (nreverse (gnu_before_list), + nreverse (gnu_after_list)); + if (TREE_CHAIN (gnu_result)) + gnu_result = build_nt (BLOCK_STMT, gnu_result); } break; @@ -3895,22 +3902,10 @@ tree_transform (Node_Id gnat_node) gnu_input_list = nreverse (gnu_input_list); gnu_output_list = nreverse (gnu_output_list); gnu_orig_out_list = nreverse (gnu_orig_out_list); - expand_asm_operands (gnu_template, gnu_output_list, gnu_input_list, - gnu_clobber_list, Is_Asm_Volatile (gnat_node), - input_location); - - /* Copy all the intermediate outputs into the specified outputs. */ - for (; gnu_output_list; - (gnu_output_list = TREE_CHAIN (gnu_output_list), - gnu_orig_out_list = TREE_CHAIN (gnu_orig_out_list))) - if (TREE_VALUE (gnu_orig_out_list) != TREE_VALUE (gnu_output_list)) - { - expand_expr_stmt - (build_binary_op (MODIFY_EXPR, NULL_TREE, - TREE_VALUE (gnu_orig_out_list), - TREE_VALUE (gnu_output_list))); - free_temp_slots (); - } + gnu_result = build_nt (ASM_STMT, gnu_template, gnu_output_list, + gnu_orig_out_list, gnu_input_list, + gnu_clobber_list); + TREE_THIS_VOLATILE (gnu_result) = Is_Asm_Volatile (gnat_node); } break; @@ -3974,11 +3969,12 @@ tree_transform (Node_Id gnat_node) gnu_ptr, gnu_byte_offset); } - set_lineno (gnat_node, 1); - expand_expr_stmt - (build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align, - Procedure_To_Call (gnat_node), - Storage_Pool (gnat_node), gnat_node)); + gnu_result + = build_nt (EXPR_STMT, + build_call_alloc_dealloc + (gnu_ptr, gnu_obj_size, align, + Procedure_To_Call (gnat_node), + Storage_Pool (gnat_node), gnat_node)); } break; @@ -3997,15 +3993,14 @@ tree_transform (Node_Id gnat_node) is one. */ if (TREE_CODE (gnu_result_type) == VOID_TYPE) { - set_lineno (gnat_node, 1); + gnu_result = build_nt (EXPR_STMT, gnu_result); + TREE_TYPE (gnu_result) = void_type_node; + TREE_SLOC (gnu_result) = Sloc (gnat_node); if (Present (Condition (gnat_node))) - expand_start_cond (gnat_to_gnu (Condition (gnat_node)), 0); - - expand_expr_stmt (gnu_result); - if (Present (Condition (gnat_node))) - expand_end_cond (); - gnu_result = error_mark_node; + gnu_result = build_nt (IF_STMT, + gnat_to_gnu (Condition (gnat_node)), + gnu_result, NULL_TREE, NULL_TREE); } else gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result); @@ -4235,7 +4230,7 @@ make_expr_stmt_from_rtl (rtx insns, Node_Id gnat_node) void gnat_expand_stmt (tree gnu_stmt) { - tree gnu_elmt; + tree gnu_elmt, gnu_elmt_2; if (TREE_SLOC (gnu_stmt)) set_lineno_from_sloc (TREE_SLOC (gnu_stmt), 1); @@ -4283,11 +4278,6 @@ gnat_expand_stmt (tree gnu_stmt) case LABEL_STMT: expand_label (LABEL_STMT_LABEL (gnu_stmt)); - if (LABEL_STMT_FIRST_IN_EH (gnu_stmt)) - nonlocal_goto_handler_labels - = gen_rtx_EXPR_LIST (VOIDmode, - label_rtx (LABEL_STMT_LABEL (gnu_stmt)), - nonlocal_goto_handler_labels); break; case RETURN_STMT: @@ -4299,6 +4289,29 @@ gnat_expand_stmt (tree gnu_stmt) expand_null_return (); break; + case ASM_STMT: + expand_asm_operands (ASM_STMT_TEMPLATE (gnu_stmt), + ASM_STMT_OUTPUT (gnu_stmt), + ASM_STMT_INPUT (gnu_stmt), + ASM_STMT_CLOBBER (gnu_stmt), + TREE_THIS_VOLATILE (gnu_stmt), input_location); + + /* Copy all the intermediate outputs into the specified outputs. */ + for ((gnu_elmt = ASM_STMT_OUTPUT (gnu_stmt), + gnu_elmt_2 = ASM_STMT_ORIG_OUT (gnu_stmt)); + gnu_elmt; + (gnu_elmt = TREE_CHAIN (gnu_elmt), + gnu_elmt_2 = TREE_CHAIN (gnu_elmt_2))) + if (TREE_VALUE (gnu_elmt) != TREE_VALUE (gnu_elmt_2)) + { + expand_expr_stmt + (build_binary_op (MODIFY_EXPR, NULL_TREE, + TREE_VALUE (gnu_elmt_2), + TREE_VALUE (gnu_elmt))); + free_temp_slots (); + } + break; + default: abort (); } diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index a2c1598..75a2acb 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -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- -- @@ -785,6 +785,7 @@ pragma Preelaborate (Types); PE_Potentially_Blocking_Operation, PE_Stubbed_Subprogram_Called, PE_Unchecked_Union_Restriction, + PE_Illegal_RACW_E_4_18, SE_Empty_Storage_Pool, SE_Explicit_Raise, @@ -798,7 +799,7 @@ pragma Preelaborate (Types); subtype RT_PE_Exceptions is RT_Exception_Code range PE_Access_Before_Elaboration .. - PE_Unchecked_Union_Restriction; + PE_Illegal_RACW_E_4_18; subtype RT_SE_Exceptions is RT_Exception_Code range SE_Empty_Storage_Pool .. diff --git a/gcc/ada/types.h b/gcc/ada/types.h index 19d2fc7..b4c4eb4 100644 --- a/gcc/ada/types.h +++ b/gcc/ada/types.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * 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- * @@ -357,10 +357,11 @@ typedef Int Mechanism_Type; #define PE_Potentially_Blocking_Operation 21 #define PE_Stubbed_Subprogram_Called 22 #define PE_Unchecked_Union_Restriction 23 -#define SE_Empty_Storage_Pool 24 -#define SE_Explicit_Raise 25 -#define SE_Infinite_Recursion 26 -#define SE_Object_Too_Large 27 -#define SE_Restriction_Violation 28 - -#define LAST_REASON_CODE 28 +#define PE_Illegal_RACW_E_4_18 24 +#define SE_Empty_Storage_Pool 25 +#define SE_Explicit_Raise 26 +#define SE_Infinite_Recursion 27 +#define SE_Object_Too_Large 28 +#define SE_Restriction_Violation 29 + +#define LAST_REASON_CODE 29 diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c index 8b0bf81..ac6e162 100644 --- a/gcc/ada/utils.c +++ b/gcc/ada/utils.c @@ -310,7 +310,10 @@ poplevel (int keep, int reverse, int functionbody) && DECL_INITIAL (decl_node) != 0) { push_function_context (); + /* ??? This is temporary. */ + ggc_push_context (); output_inline_function (decl_node); + ggc_pop_context (); pop_function_context (); } diff --git a/gcc/ada/utils2.c b/gcc/ada/utils2.c index 3c0e26b..5882d09 100644 --- a/gcc/ada/utils2.c +++ b/gcc/ada/utils2.c @@ -1225,9 +1225,12 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) } if (TYPE_FAT_POINTER_P (type)) - result = build1 (UNCONSTRAINED_ARRAY_REF, - TYPE_UNCONSTRAINED_ARRAY (type), operand); - + { + result = build1 (UNCONSTRAINED_ARRAY_REF, + TYPE_UNCONSTRAINED_ARRAY (type), operand); + TREE_READONLY (result) = TREE_STATIC (result) + = TYPE_READONLY (TYPE_UNCONSTRAINED_ARRAY (type)); + } else if (TREE_CODE (operand) == ADDR_EXPR) result = TREE_OPERAND (operand, 0); |