-- --
-- 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- --
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 --
----------------
-- --
-- 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- --
-- 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
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);
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
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 --
----------------
-- --
-- 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- --
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 --
----------------
-- --
-- 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- --
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 --
----------------
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
-- --
-- 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- --
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 --
----------------
-- 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- --
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;
-- --
-- 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- --
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 --
----------------
-- 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;
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;
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
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 --
----------------
-- --
-- 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- --
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 --
----------------
-- --
-- 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- --
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 --
----------------
-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.
(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.
# 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)
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 \
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"
-- --
-- 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- --
-- 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;
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);
---------
-- "+" --
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;
-- 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
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;
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");
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 --
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 --
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
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 --
-------------
/* 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)
#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)
}
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
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 *[]);
-- 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 --
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
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 --
--------------
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;
-------------------
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
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
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 (" ");
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
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;
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 (" ");
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
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;
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
-------------
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;
-- 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
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;
-- 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
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;
------------------
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;
-- 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;
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 --
------------------------
-- 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;
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;
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;
----------------------------------
|| 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
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);
}
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);
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 --
--------------
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 --
-----------
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;
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;
-- 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
-- _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)))
-- 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)
-- --
-- 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- --
declare
Decl : constant Node_Id := Declaration_Node (Ent);
-
begin
if Nkind (Decl) = N_Object_Declaration
and then Present (Expression (Decl))
-- 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;
-----------------
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
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
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
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);
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;
----------------------------
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;
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
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,
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;
-- --
-- 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- --
-- 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;
-- 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;
-- 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;
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 --
--------------------------------------
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;
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 --
----------
-- --
-- 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- --
-- 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;
-- --
-- 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- --
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)))
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
-- 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;
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;
-- 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
-- --
-- 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- --
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");
@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.
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
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);
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
-- 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;
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.
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.
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 --
------------------
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);
-- 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;
procedure Usage;
-- Print usage message
+ function Image (Restriction : Restriction_Id) return String;
+ -- Returns the capitalized image of Restriction
+
-----------------
-- Add_Lib_Dir --
-----------------
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 --
-------------------
-- 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);
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
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.
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);
(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 --
---------------
-- 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
#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;
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;
with Prj; use Prj;
with Prj.Com;
with Prj.Env;
-with Prj.Ext;
with Prj.Pars;
with Prj.Util;
with SFN_Scan;
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.
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
-- 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.
-- 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;
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
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;
-- 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;
Marking_Label := 1;
end Initialize;
- -----------------------------------
- -- Insert_Project_Sources_Into_Q --
- -----------------------------------
+ ----------------------------
+ -- Insert_Project_Sources --
+ ----------------------------
procedure Insert_Project_Sources
(The_Project : Project_Id;
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 --
---------------------
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 --
----------
-- 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"
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 --
-----------
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;
-- --
-- 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- --
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");
-- --
-- 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- --
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;
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 :=
-- 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
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
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
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;
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;
------------------
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 --
----------------
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;
-- --
-- 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- --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Interfaces.C.Strings;
with Hostparm;
with Opt;
package body MLib is
+ pragma Linker_Options ("link.o");
+ -- For run_path_option string.
+
-------------------
-- Build_Library --
-------------------
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;
-- --
-- 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- --
-- 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;
-- 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.
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));
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
(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));
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
(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;
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
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");
-- 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);
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));
Not_Null_Present : Boolean := False;
Subs_List : List_Id;
Scan_State : Saved_Scan_State;
+ Aliased_Present : Boolean := False;
begin
Array_Loc := Token_Ptr;
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
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);
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
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;
-- 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;
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
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
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);
-- 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
-- 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);
-- 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;
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
if Nast /= 1 then
Error_Msg_N
("file name pattern must have exactly one * character",
- Arg2);
+ Arg1);
return Pragma_Node;
end if;
-- 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;
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
Save_Style_Check : constant Boolean := Style_Check;
-
begin
Operating_Mode := Check_Syntax;
Style_Check := False;
-- 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.
-- --
------------------------------------------------------------------------------
--- 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
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;
-- 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.
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;
-- 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;
-- 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;
-- 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);
+ 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.
- 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 => "=");
+ 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.
- function Hash (Unit : Unit_Info) return Header_Num;
+ procedure Show_Source_Dirs (Project : Project_Id);
+ -- List all the source directories of a project.
- 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.
+ 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.
- 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.
+ ---------------
+ -- Ada_Check --
+ ---------------
- procedure Free_Naming_Exceptions;
- -- Free the internal hash tables used for checking naming exceptions
+ procedure Ada_Check
+ (Project : Project_Id;
+ Report_Error : Put_Line_Access;
+ Follow_Links : Boolean)
+ is
+ Data : Project_Data;
+ Languages : Variable_Value := Nil_Variable_Value;
- 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
+ Extending : Boolean := False;
- ----------------------------
- -- Compute_Directory_Last --
- ----------------------------
+ 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.
- 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;
+ procedure Get_Sources_From_File
+ (Path : String;
+ Location : Source_Ptr);
+ -- Get the sources of a project from a text file
- -------------------------------
- -- Prepare_Naming_Exceptions --
- -------------------------------
+ procedure Warn_If_Not_Sources
+ (Conventions : Array_Element_Id;
+ Specs : Boolean);
+ -- Check that individual naming conventions apply to immediate
+ -- sources of the project; if not, issue a warning.
- procedure Prepare_Naming_Exceptions
- (List : Array_Element_Id;
- Kind : Spec_Or_Body)
- is
- Current : Array_Element_Id := List;
- Element : Array_Element;
+ ---------------------------------------
+ -- Get_Path_Names_And_Record_Sources --
+ ---------------------------------------
- begin
- while Current /= No_Array_Element loop
- Element := Array_Elements.Table (Current);
+ procedure Get_Path_Names_And_Record_Sources is
+ Source_Dir : String_List_Id := Data.Source_Dirs;
+ Element : String_Element;
+ Path : Name_Id;
- 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;
+ Dir : Dir_Type;
+ Name : Name_Id;
+ Canonical_Name : Name_Id;
+ Name_Str : String (1 .. 1_024);
+ Last : Natural := 0;
+ NL : Name_Location;
- Current := Element.Next;
- end loop;
- end Prepare_Naming_Exceptions;
+ Current_Source : String_List_Id := Nil_String;
- ----------
- -- Hash --
- ----------
+ First_Error : Boolean := True;
- function Hash (Unit : Unit_Info) return Header_Num is
- begin
- return Header_Num (Unit.Unit mod 2048);
- end Hash;
+ Source_Recorded : Boolean := False;
- ----------------------------
- -- Free_Naming_Exceptions --
- ----------------------------
+ begin
+ -- We look in all source directories for the file names in the
+ -- hash table Source_Names
- procedure Free_Naming_Exceptions is
- begin
- Naming_Exceptions.Reset;
- Reverse_Naming_Exceptions.Reset;
- end Free_Naming_Exceptions;
+ while Source_Dir /= Nil_String loop
+ Source_Recorded := False;
+ Element := String_Elements.Table (Source_Dir);
- -------------------------
- -- Check_Naming_Scheme --
- -------------------------
+ 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_Line ("""");
+ end if;
- 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);
+ Open (Dir, Dir_Path);
- Naming : Package_Element;
+ loop
+ Read (Dir, Name_Str, Last);
+ exit when Last = 0;
+ Name_Len := Last;
+ Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last);
+ Name := Name_Find;
+ Canonical_Case_File_Name (Name_Str (1 .. Last));
+ Name_Len := Last;
+ Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last);
+ Canonical_Name := Name_Find;
+ NL := Source_Names.Get (Canonical_Name);
- procedure Check_Unit_Names (List : Array_Element_Id);
- -- Check that a list of unit names contains only valid names.
+ if NL /= No_Name_Location and then not NL.Found then
+ 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_Unit_Names --
- ----------------------
+ if Current_Verbosity = High then
+ Write_Str (" found ");
+ Write_Line (Get_Name_String (Name));
+ end if;
- procedure Check_Unit_Names (List : Array_Element_Id) is
- Current : Array_Element_Id := List;
- Element : Array_Element;
- Unit_Name : Name_Id;
+ -- Register the source if it is an Ada compilation unit..
- begin
- -- Loop through elements of the string list
+ Record_Ada_Source
+ (File_Name => Name,
+ Path_Name => Path,
+ Project => Project,
+ Data => Data,
+ Location => NL.Location,
+ Current_Source => Current_Source,
+ Source_Recorded => Source_Recorded,
+ Follow_Links => Follow_Links);
+ end if;
+ end loop;
- while Current /= No_Array_Element loop
- Element := Array_Elements.Table (Current);
+ Close (Dir);
+ end;
- -- Put file name in canonical case
+ if Source_Recorded then
+ String_Elements.Table (Source_Dir).Flag := True;
+ end if;
- Get_Name_String (Element.Value.Value);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Element.Value.Value := Name_Find;
+ Source_Dir := Element.Next;
+ end loop;
- -- Check that it contains a valid unit name
+ -- It is an error if a source file name in a source list or
+ -- in a source list file is not found.
- Get_Name_String (Element.Index);
- Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit_Name);
+ NL := Source_Names.Get_First;
- 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);
+ while NL /= No_Name_Location loop
+ if not NL.Found then
+ Err_Vars.Error_Msg_Name_1 := NL.Name;
- else
- if Current_Verbosity = High then
- Write_Str (" Unit (""");
- Write_Str (Get_Name_String (Unit_Name));
- Write_Line (""")");
- end if;
+ if First_Error then
+ Error_Msg
+ (Project,
+ "source file { cannot be found",
+ NL.Location);
+ First_Error := False;
- Element.Index := Unit_Name;
- Array_Elements.Table (Current) := Element;
+ else
+ Error_Msg
+ (Project,
+ "\source file { cannot be found",
+ NL.Location);
+ end if;
end if;
- Current := Element.Next;
+ NL := Source_Names.Get_Next;
end loop;
- end Check_Unit_Names;
+ end Get_Path_Names_And_Record_Sources;
- -- Start of processing for Check_Naming_Scheme
+ ---------------------------
+ -- Get_Sources_From_File --
+ ---------------------------
- begin
- -- If there is a package Naming, we will put in Data.Naming what is in
- -- this package Naming.
+ procedure Get_Sources_From_File
+ (Path : String;
+ Location : Source_Ptr)
+ is
+ begin
+ -- Get the list of sources from the file and put them in hash table
+ -- Source_Names.
- if Naming_Id /= No_Package then
- Naming := Packages.Table (Naming_Id);
+ Get_Sources_From_File (Path, Location, Project);
- if Current_Verbosity = High then
- Write_Line ("Checking ""Naming"" for Ada.");
- end if;
+ -- Look in the source directories to find those sources
- declare
- Bodies : constant Array_Element_Id :=
- Util.Value_Of (Name_Body, Naming.Decl.Arrays);
+ Get_Path_Names_And_Record_Sources;
- Specs : constant Array_Element_Id :=
- Util.Value_Of (Name_Spec, Naming.Decl.Arrays);
+ -- We should have found at least one source.
+ -- If not, report an error.
- begin
- if Bodies /= No_Array_Element then
+ if Data.Sources = Nil_String then
+ Error_Msg (Project,
+ "there are no Ada sources in this project",
+ Location);
+ end if;
+ end Get_Sources_From_File;
- -- We have elements in the array Body_Part
+ -------------------------
+ -- Warn_If_Not_Sources --
+ -------------------------
- if Current_Verbosity = High then
- Write_Line ("Found Bodies.");
- end if;
+ procedure Warn_If_Not_Sources
+ (Conventions : Array_Element_Id;
+ Specs : Boolean)
+ is
+ Conv : Array_Element_Id := Conventions;
+ Unit : Name_Id;
+ The_Unit_Id : Unit_Id;
+ The_Unit_Data : Unit_Data;
+ Location : Source_Ptr;
- Data.Naming.Bodies := Bodies;
- Check_Unit_Names (Bodies);
+ begin
+ while Conv /= No_Array_Element loop
+ Unit := Array_Elements.Table (Conv).Index;
+ Error_Msg_Name_1 := Unit;
+ Get_Name_String (Unit);
+ To_Lower (Name_Buffer (1 .. Name_Len));
+ Unit := Name_Find;
+ The_Unit_Id := Units_Htable.Get (Unit);
+ Location := Array_Elements.Table (Conv).Value.Location;
- else
- if Current_Verbosity = High then
- Write_Line ("No Bodies.");
- end if;
- end if;
+ if The_Unit_Id = Prj.Com.No_Unit then
+ Error_Msg
+ (Project,
+ "?unknown unit {",
+ Location);
- if Specs /= No_Array_Element then
+ else
+ The_Unit_Data := Units.Table (The_Unit_Id);
- -- We have elements in the array Specs
+ if Specs then
+ if not Check_Project
+ (The_Unit_Data.File_Names (Specification).Project,
+ Project, Extending)
+ then
+ Error_Msg
+ (Project,
+ "?unit{ has no spec in this project",
+ Location);
+ end if;
- if Current_Verbosity = High then
- Write_Line ("Found Specs.");
+ else
+ if not Check_Project
+ (The_Unit_Data.File_Names (Com.Body_Part).Project,
+ Project, Extending)
+ then
+ Error_Msg
+ (Project,
+ "?unit{ has no body in this project",
+ Location);
+ end if;
end if;
+ end if;
- Data.Naming.Specs := Specs;
- Check_Unit_Names (Specs);
+ Conv := Array_Elements.Table (Conv).Next;
+ end loop;
+ end Warn_If_Not_Sources;
- else
- if Current_Verbosity = High then
- Write_Line ("No Specs.");
- end if;
- end if;
- end;
+ -- Start of processing for Ada_Check
- -- We are now checking if variables Dot_Replacement, Casing,
- -- Spec_Suffix, Body_Suffix and/or Separate_Suffix
- -- exist.
+ begin
+ Language_Independent_Check (Project, Report_Error);
- -- For each variable, if it does not exist, we do nothing,
- -- because we already have the default.
+ Error_Report := Report_Error;
- -- Check Dot_Replacement
+ Data := Projects.Table (Project);
+ Extending := Data.Extends /= No_Project;
+ Languages := Prj.Util.Value_Of (Name_Languages, Data.Decl.Attributes);
+
+ Data.Naming.Current_Language := Name_Ada;
+ Data.Sources_Present := Data.Source_Dirs /= Nil_String;
+ if not Languages.Default then
declare
- Dot_Replacement : constant Variable_Value :=
- Util.Value_Of
- (Name_Dot_Replacement,
- Naming.Decl.Attributes);
+ Current : String_List_Id := Languages.Values;
+ Element : String_Element;
+ Ada_Found : Boolean := False;
begin
- pragma Assert (Dot_Replacement.Kind = Single,
- "Dot_Replacement is not a single string");
+ Look_For_Ada : while Current /= Nil_String loop
+ Element := String_Elements.Table (Current);
+ Get_Name_String (Element.Value);
+ To_Lower (Name_Buffer (1 .. Name_Len));
- if not Dot_Replacement.Default then
- Get_Name_String (Dot_Replacement.Value);
+ if Name_Buffer (1 .. Name_Len) = "ada" then
+ Ada_Found := True;
+ exit Look_For_Ada;
+ end if;
- if Name_Len = 0 then
- Error_Msg
- (Project,
- "Dot_Replacement cannot be empty",
- Dot_Replacement.Location);
+ Current := Element.Next;
+ end loop Look_For_Ada;
- 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;
+ if not Ada_Found then
+
+ -- Mark the project file as having no sources for Ada
+
+ Data.Sources_Present := False;
end if;
end;
+ end if;
- 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_Naming_Scheme (Data, Project);
- -- Check Casing
+ Prepare_Ada_Naming_Exceptions (Data.Naming.Bodies, Body_Part);
+ Prepare_Ada_Naming_Exceptions (Data.Naming.Specs, Specification);
- declare
- Casing_String : constant Variable_Value :=
- Util.Value_Of
- (Name_Casing, Naming.Decl.Attributes);
+ -- If we have source directories, then find the sources
- begin
- pragma Assert (Casing_String.Kind = Single,
- "Casing is not a single string");
+ if Data.Sources_Present then
+ if Data.Source_Dirs = Nil_String then
+ Data.Sources_Present := False;
- 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;
+ else
+ declare
+ Sources : constant Variable_Value :=
+ Util.Value_Of
+ (Name_Source_Files,
+ Data.Decl.Attributes);
- exception
- when Constraint_Error =>
- if Casing_Image'Length = 0 then
- Error_Msg
- (Project,
- "Casing cannot be an empty string",
- Casing_String.Location);
+ Source_List_File : constant Variable_Value :=
+ Util.Value_Of
+ (Name_Source_List_File,
+ Data.Decl.Attributes);
- 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;
+ Locally_Removed : constant Variable_Value :=
+ Util.Value_Of
+ (Name_Locally_Removed_Files,
+ Data.Decl.Attributes);
- -- Check Spec_Suffix
- declare
- Ada_Spec_Suffix : constant Variable_Value :=
- Prj.Util.Value_Of
- (Index => Name_Ada,
- In_Array => Data.Naming.Spec_Suffix);
+ begin
+ pragma Assert
+ (Sources.Kind = List,
+ "Source_Files is not a list");
- 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;
+ pragma Assert
+ (Source_List_File.Kind = Single,
+ "Source_List_File is not a single string");
- else
- Data.Naming.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
- end if;
- end;
+ 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;
- 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;
+ -- Sources is a list of file names
- -- Check Body_Suffix
+ declare
+ Current : String_List_Id := Sources.Values;
+ Element : String_Element;
+ Location : Source_Ptr;
+ Name : Name_Id;
- declare
- Ada_Body_Suffix : constant Variable_Value :=
- Prj.Util.Value_Of
- (Index => Name_Ada,
- In_Array => Data.Naming.Body_Suffix);
+ begin
+ Source_Names.Reset;
- 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;
+ Data.Sources_Present := Current /= Nil_String;
- else
- Data.Naming.Current_Body_Suffix := Default_Ada_Body_Suffix;
- end if;
- end;
+ 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 Current_Verbosity = High then
- Write_Str (" Body_Suffix = """);
- Write_Str (Get_Name_String (Data.Naming.Current_Body_Suffix));
- Write_Char ('"');
- Write_Eol;
- end if;
+ -- If the element has no location, then use the
+ -- location of Sources to report possible errors.
- -- Check Separate_Suffix
+ if Element.Location = No_Location then
+ Location := Sources.Location;
- declare
- Ada_Sep_Suffix : constant Variable_Value :=
- Prj.Util.Value_Of
- (Variable_Name => Name_Separate_Suffix,
- In_Variables => Naming.Decl.Attributes);
+ else
+ Location := Element.Location;
+ end if;
- begin
- if Ada_Sep_Suffix.Default then
- Data.Naming.Separate_Suffix :=
- Data.Naming.Current_Body_Suffix;
+ Source_Names.Set
+ (K => Name,
+ E =>
+ (Name => Name,
+ Location => Location,
+ Found => False));
- else
- if Get_Name_String (Ada_Sep_Suffix.Value) = "" then
- Error_Msg
- (Project,
- "Separate_Suffix cannot be empty",
- Ada_Sep_Suffix.Location);
+ Current := Element.Next;
+ end loop;
- else
- Data.Naming.Separate_Suffix := Ada_Sep_Suffix.Value;
- Data.Naming.Sep_Suffix_Loc := Ada_Sep_Suffix.Location;
- end if;
- end if;
- end;
+ Get_Path_Names_And_Record_Sources;
+ 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;
+ -- No source_files specified
- -- Check if Data.Naming is valid
+ -- We check Source_List_File has been specified.
- Check_Ada_Naming_Scheme (Project, Data.Naming);
+ elsif not Source_List_File.Default then
- 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;
+ -- Source_List_File is the name of the file
+ -- that contains the source file names
- ---------------
- -- Ada_Check --
- ---------------
+ declare
+ Source_File_Path_Name : constant String :=
+ Path_Name_Of
+ (Source_List_File.Value,
+ Data.Directory);
- procedure Ada_Check
- (Project : Project_Id;
- Report_Error : Put_Line_Access;
- Trusted_Mode : Boolean)
- is
- Data : Project_Data;
- Languages : Variable_Value := Nil_Variable_Value;
+ 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);
- Extending : Boolean := False;
+ else
+ Get_Sources_From_File
+ (Source_File_Path_Name,
+ Source_List_File.Location);
+ end if;
+ end;
- function Check_Project (P : Project_Id) return Boolean;
- -- Returns True if P is Project or a project extended by Project
+ 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.
- procedure Find_Sources;
- -- Find all the sources in all of the source directories
- -- of a project.
+ Find_Sources (Project, Data, Lang_Ada, Follow_Links);
+ end if;
- 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.
+ -- If there are sources that are locally removed, mark them as
+ -- such in the Units table.
- procedure Get_Sources_From_File
- (Path : String;
- Location : Source_Ptr);
- -- Get the sources of a project from a text file
+ if not Locally_Removed.Default then
- procedure Warn_If_Not_Sources
- (Conventions : Array_Element_Id;
- Specs : Boolean);
- -- Check that individual naming conventions apply to immediate
- -- sources of the project; if not, issue a warning.
+ -- Sources can be locally removed only in extending
+ -- project files.
- -------------------
- -- Check_Project --
- -------------------
+ if Data.Extends = No_Project then
+ Error_Msg
+ (Project,
+ "Locally_Removed_Files can only be used " &
+ "in an extending project file",
+ Locally_Removed.Location);
- 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);
+ else
+ declare
+ Current : String_List_Id :=
+ Locally_Removed.Values;
+ Element : String_Element;
+ Location : Source_Ptr;
+ OK : Boolean;
+ Unit : Unit_Data;
+ Name : Name_Id;
+ Extended : Project_Id;
- begin
- while Data.Extends /= No_Project loop
- if P = Data.Extends then
- return True;
- end if;
+ begin
+ 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;
- Data := Projects.Table (Data.Extends);
- end loop;
- end;
- end if;
+ -- If the element has no location, then use the
+ -- location of Locally_Removed to report
+ -- possible errors.
- return False;
- end Check_Project;
+ if Element.Location = No_Location then
+ Location := Locally_Removed.Location;
- ------------------
- -- Find_Sources --
- ------------------
+ else
+ Location := Element.Location;
+ end if;
- 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;
+ OK := False;
- begin
- if Current_Verbosity = High then
- Write_Line ("Looking for sources:");
- end if;
+ for Index in 1 .. Units.Last loop
+ Unit := Units.Table (Index);
- -- For each subdirectory
+ if
+ Unit.File_Names (Specification).Name = Name
+ then
+ OK := True;
- 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);
+ -- Check that this is from a project that
+ -- the current project extends, but not the
+ -- current project.
- begin
- if Current_Verbosity = High then
- Write_Str ("Source_Dir = ");
- Write_Line (Source_Directory);
- end if;
+ Extended := Unit.File_Names
+ (Specification).Project;
- -- We look to every entry in the source directory
+ if Extended = Project then
+ Error_Msg
+ (Project,
+ "cannot remove a source " &
+ "of the same project",
+ Location);
- Open (Dir, Source_Directory
- (Source_Directory'First .. Dir_Last));
+ elsif
+ Project_Extends (Project, Extended)
+ then
+ Unit.File_Names
+ (Specification).Path := Slash;
+ Unit.File_Names
+ (Specification).Needs_Pragma := False;
+ Units.Table (Index) := Unit;
+ Add_Forbidden_File_Name
+ (Unit.File_Names (Specification).Name);
+ exit;
- -- Canonical_Case_File_Name (Source_Directory);
+ else
+ Error_Msg
+ (Project,
+ "cannot remove a source from " &
+ "another project",
+ Location);
+ end if;
- loop
- Read (Dir, Name_Buffer, Name_Len);
+ elsif
+ Unit.File_Names (Body_Part).Name = Name
+ then
+ OK := True;
- if Current_Verbosity = High then
- Write_Str (" Checking ");
- Write_Line (Name_Buffer (1 .. Name_Len));
- end if;
+ -- Check that this is from a project that
+ -- the current project extends, but not the
+ -- current project.
- exit when Name_Len = 0;
+ Extended := Unit.File_Names
+ (Body_Part).Project;
- 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;
+ if Extended = Project then
+ Error_Msg
+ (Project,
+ "cannot remove a source " &
+ "of the same project",
+ Location);
- 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);
+ elsif
+ Project_Extends (Project, Extended)
+ then
+ Unit.File_Names (Body_Part).Path := Slash;
+ Unit.File_Names (Body_Part).Needs_Pragma
+ := False;
+ Units.Table (Index) := Unit;
+ Add_Forbidden_File_Name
+ (Unit.File_Names (Body_Part).Name);
+ exit;
+ end if;
+
+ end if;
+ end loop;
+
+ if not OK then
+ Err_Vars.Error_Msg_Name_1 := Name;
+ Error_Msg (Project, "unknown file {", Location);
end if;
- end;
- end loop;
- Close (Dir);
- end;
+ Current := Element.Next;
+ end loop;
+ end;
+ end if;
end if;
-
- exception
- when Directory_Error =>
- null;
end;
+ end if;
+ end if;
- if Source_Recorded then
- String_Elements.Table (Source_Dir).Flag := True;
- end if;
+ if Data.Sources_Present then
- Source_Dir := Element.Next;
- end loop;
+ -- Check that all individual naming conventions apply to
+ -- sources of this project file.
- if Current_Verbosity = High then
- Write_Line ("end Looking for sources.");
- end if;
+ Warn_If_Not_Sources (Data.Naming.Bodies, Specs => False);
+ Warn_If_Not_Sources (Data.Naming.Specs, Specs => True);
+ 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 it is a library project file, check if it is a standalone library
- if Current_Source /= Nil_String then
- Data.Sources_Present := True;
+ if Data.Library then
+ Standalone_Library : declare
+ Lib_Interfaces : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Interface,
+ Data.Decl.Attributes);
+ Lib_Auto_Init : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Auto_Init,
+ Data.Decl.Attributes);
- elsif Data.Extends = No_Project then
- Error_Msg
- (Project,
- "there are no Ada sources in this project",
- Data.Location);
- end if;
- end Find_Sources;
+ Lib_Src_Dir : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Src_Dir,
+ Data.Decl.Attributes);
- ---------------------------------------
- -- Get_Path_Names_And_Record_Sources --
- ---------------------------------------
+ Lib_Symbol_File : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Symbol_File,
+ Data.Decl.Attributes);
- procedure Get_Path_Names_And_Record_Sources is
- Source_Dir : String_List_Id := Data.Source_Dirs;
- Element : String_Element;
- Path : Name_Id;
+ Lib_Symbol_Policy : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Symbol_Policy,
+ Data.Decl.Attributes);
- Dir : Dir_Type;
- Name : Name_Id;
- Canonical_Name : Name_Id;
- Name_Str : String (1 .. 1_024);
- Last : Natural := 0;
- NL : Name_Location;
+ Lib_Ref_Symbol_File : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Reference_Symbol_File,
+ Data.Decl.Attributes);
- Current_Source : String_List_Id := Nil_String;
+ Auto_Init_Supported : constant Boolean :=
+ MLib.Tgt.
+ Standalone_Library_Auto_Init_Is_Supported;
- First_Error : Boolean := True;
+ OK : Boolean := True;
- Source_Recorded : Boolean := False;
+ begin
+ pragma Assert (Lib_Interfaces.Kind = List);
- begin
- -- We look in all source directories for this file name
+ -- It is a stand-alone library project file if attribute
+ -- Library_Interface is defined.
- while Source_Dir /= Nil_String loop
- Source_Recorded := False;
- Element := String_Elements.Table (Source_Dir);
+ if not Lib_Interfaces.Default then
+ declare
+ Interfaces : String_List_Id := Lib_Interfaces.Values;
+ Interface_ALIs : String_List_Id := Nil_String;
+ Unit : Name_Id;
+ The_Unit_Id : Unit_Id;
+ The_Unit_Data : Unit_Data;
- 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_Line ("""");
- end if;
+ procedure Add_ALI_For (Source : Name_Id);
+ -- Add an ALI file name to the list of Interface ALIs
- Open (Dir, Dir_Path);
+ -----------------
+ -- Add_ALI_For --
+ -----------------
- loop
- Read (Dir, Name_Str, Last);
- exit when Last = 0;
- Name_Len := Last;
- Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last);
- Name := Name_Find;
- Canonical_Case_File_Name (Name_Str (1 .. Last));
- Name_Len := Last;
- Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last);
- Canonical_Name := Name_Find;
- NL := Source_Names.Get (Canonical_Name);
+ procedure Add_ALI_For (Source : Name_Id) is
+ begin
+ Get_Name_String (Source);
- if NL /= No_Name_Location and then not NL.Found then
- 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;
+ declare
+ ALI : constant String :=
+ ALI_File_Name (Name_Buffer (1 .. Name_Len));
+ ALI_Name_Id : Name_Id;
+ begin
+ Name_Len := ALI'Length;
+ Name_Buffer (1 .. Name_Len) := ALI;
+ ALI_Name_Id := Name_Find;
- if Current_Verbosity = High then
- Write_Str (" found ");
- Write_Line (Get_Name_String (Name));
- end if;
+ String_Elements.Increment_Last;
+ String_Elements.Table (String_Elements.Last) :=
+ (Value => ALI_Name_Id,
+ Display_Value => ALI_Name_Id,
+ Location => String_Elements.Table
+ (Interfaces).Location,
+ Flag => False,
+ Next => Interface_ALIs);
+ Interface_ALIs := String_Elements.Last;
+ end;
+ end Add_ALI_For;
- -- Register the source if it is an Ada compilation unit..
+ begin
+ Data.Standalone_Library := True;
- Record_Source
- (File_Name => Name,
- Path_Name => Path,
- Project => Project,
- Data => Data,
- Location => NL.Location,
- Current_Source => Current_Source,
- Source_Recorded => Source_Recorded,
- Trusted_Mode => Trusted_Mode);
- end if;
- end loop;
+ -- Library_Interface cannot be an empty list
- Close (Dir);
- end;
+ if Interfaces = Nil_String then
+ Error_Msg
+ (Project,
+ "Library_Interface cannot be an empty list",
+ Lib_Interfaces.Location);
+ end if;
- if Source_Recorded then
- String_Elements.Table (Source_Dir).Flag := True;
- end if;
+ -- Process each unit name specified in the attribute
+ -- Library_Interface.
- Source_Dir := Element.Next;
- end loop;
+ while Interfaces /= Nil_String loop
+ Get_Name_String
+ (String_Elements.Table (Interfaces).Value);
+ To_Lower (Name_Buffer (1 .. Name_Len));
- -- It is an error if a source file name in a source list or
- -- in a source list file is not found.
+ if Name_Len = 0 then
+ Error_Msg
+ (Project,
+ "an interface cannot be an empty string",
+ String_Elements.Table (Interfaces).Location);
- NL := Source_Names.Get_First;
+ else
+ Unit := Name_Find;
+ Error_Msg_Name_1 := Unit;
+ The_Unit_Id := Units_Htable.Get (Unit);
- while NL /= No_Name_Location loop
- if not NL.Found then
- Err_Vars.Error_Msg_Name_1 := NL.Name;
+ if The_Unit_Id = Prj.Com.No_Unit then
+ Error_Msg
+ (Project,
+ "unknown unit {",
+ String_Elements.Table (Interfaces).Location);
- if First_Error then
- Error_Msg
- (Project,
- "source file { cannot be found",
- NL.Location);
- First_Error := False;
+ else
+ -- Check that the unit is part of the project
- else
- Error_Msg
- (Project,
- "\source file { cannot be found",
- NL.Location);
- end if;
- end if;
+ The_Unit_Data := Units.Table (The_Unit_Id);
- NL := Source_Names.Get_Next;
- end loop;
- end Get_Path_Names_And_Record_Sources;
+ if The_Unit_Data.File_Names
+ (Com.Body_Part).Name /= No_Name
+ and then The_Unit_Data.File_Names
+ (Com.Body_Part).Path /= Slash
+ then
+ if Check_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
+ -- that it is not a subunit.
- ---------------------------
- -- Get_Sources_From_File --
- ---------------------------
+ if The_Unit_Data.File_Names
+ (Specification).Name = No_Name
+ then
+ declare
+ Src_Ind : Source_File_Index;
- procedure Get_Sources_From_File
- (Path : String;
- Location : Source_Ptr)
- is
- File : Prj.Util.Text_File;
- Line : String (1 .. 250);
- Last : Natural;
- Source_Name : Name_Id;
+ begin
+ Src_Ind := Sinput.P.Load_Project_File
+ (Get_Name_String
+ (The_Unit_Data.File_Names
+ (Body_Part).Path));
- begin
- if Current_Verbosity = High then
- Write_Str ("Opening """);
- Write_Str (Path);
- Write_Line (""".");
- end if;
+ if Sinput.P.Source_File_Is_Subunit
+ (Src_Ind)
+ then
+ Error_Msg
+ (Project,
+ "{ is a subunit; " &
+ "it cannot be an interface",
+ String_Elements.Table
+ (Interfaces).Location);
+ end if;
+ end;
+ end if;
- -- We open the file
+ -- The unit is not a subunit, so we add
+ -- to the Interface ALIs the ALI file
+ -- corresponding to the body.
- Prj.Util.Open (File, Path);
+ Add_ALI_For
+ (The_Unit_Data.File_Names (Body_Part).Name);
- if not Prj.Util.Is_Valid (File) then
- Error_Msg (Project, "file does not exist", Location);
- else
- Source_Names.Reset;
+ else
+ Error_Msg
+ (Project,
+ "{ is not an unit of this project",
+ String_Elements.Table
+ (Interfaces).Location);
+ end if;
- while not Prj.Util.End_Of_File (File) loop
- Prj.Util.Get_Line (File, Line, Last);
+ elsif The_Unit_Data.File_Names
+ (Com.Specification).Name /= No_Name
+ and then The_Unit_Data.File_Names
+ (Com.Specification).Path /= Slash
+ and then Check_Project
+ (The_Unit_Data.File_Names
+ (Specification).Project,
+ Project, Extending)
- -- 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.
+ then
+ -- The unit is part of the project, it has
+ -- a spec, but no body. We add to the Interface
+ -- ALIs the ALI file corresponding to the spec.
- 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;
+ Add_ALI_For
+ (The_Unit_Data.File_Names (Specification).Name);
- Prj.Util.Close (File);
+ else
+ Error_Msg
+ (Project,
+ "{ is not an unit of this project",
+ String_Elements.Table (Interfaces).Location);
+ end if;
+ end if;
- end if;
+ end if;
- Get_Path_Names_And_Record_Sources;
+ Interfaces := String_Elements.Table (Interfaces).Next;
+ end loop;
- -- We should have found at least one source.
- -- If not, report an error.
+ -- Put the list of Interface ALIs in the project data
- if Data.Sources = Nil_String then
- Error_Msg (Project,
- "there are no Ada sources in this project",
- Location);
- end if;
- end Get_Sources_From_File;
+ Data.Lib_Interface_ALIs := Interface_ALIs;
- -------------------------
- -- Warn_If_Not_Sources --
- -------------------------
+ -- Check value of attribute Library_Auto_Init and set
+ -- Lib_Auto_Init accordingly.
- procedure Warn_If_Not_Sources
- (Conventions : Array_Element_Id;
- Specs : Boolean)
- is
- Conv : Array_Element_Id := Conventions;
- Unit : Name_Id;
- The_Unit_Id : Unit_Id;
- The_Unit_Data : Unit_Data;
- Location : Source_Ptr;
+ if Lib_Auto_Init.Default then
- begin
- while Conv /= No_Array_Element loop
- Unit := Array_Elements.Table (Conv).Index;
- Error_Msg_Name_1 := Unit;
- Get_Name_String (Unit);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Unit := Name_Find;
- The_Unit_Id := Units_Htable.Get (Unit);
- Location := Array_Elements.Table (Conv).Value.Location;
+ -- If no attribute Library_Auto_Init is declared, then
+ -- set auto init only if it is supported.
- if The_Unit_Id = Prj.Com.No_Unit then
- Error_Msg
- (Project,
- "?unknown unit {",
- Location);
+ Data.Lib_Auto_Init := Auto_Init_Supported;
- else
- The_Unit_Data := Units.Table (The_Unit_Id);
+ else
+ Get_Name_String (Lib_Auto_Init.Value);
+ To_Lower (Name_Buffer (1 .. Name_Len));
- if Specs then
- if not Check_Project
- (The_Unit_Data.File_Names (Specification).Project)
- then
- Error_Msg
- (Project,
- "?unit{ has no spec in this project",
- Location);
- end if;
+ if Name_Buffer (1 .. Name_Len) = "false" then
+ Data.Lib_Auto_Init := False;
- else
- if not Check_Project
- (The_Unit_Data.File_Names (Com.Body_Part).Project)
- then
- Error_Msg
- (Project,
- "?unit{ has no body in this project",
- Location);
- end if;
- end if;
- end if;
+ elsif Name_Buffer (1 .. Name_Len) = "true" then
+ if Auto_Init_Supported then
+ Data.Lib_Auto_Init := True;
- Conv := Array_Elements.Table (Conv).Next;
- end loop;
- end Warn_If_Not_Sources;
+ else
+ -- Library_Auto_Init cannot be "true" if auto init
+ -- is not supported
- -- Start of processing for Ada_Check
+ Error_Msg
+ (Project,
+ "library auto init not supported " &
+ "on this platform",
+ Lib_Auto_Init.Location);
+ end if;
- begin
- Language_Independent_Check (Project, Report_Error);
+ else
+ Error_Msg
+ (Project,
+ "invalid value for attribute Library_Auto_Init",
+ Lib_Auto_Init.Location);
+ end if;
+ end if;
+ end;
- Error_Report := Report_Error;
+ -- If attribute Library_Src_Dir is defined and not the
+ -- empty string, check if the directory exist and is not
+ -- the object directory or one of the source directories.
+ -- This is the directory where copies of the interface
+ -- sources will be copied. Note that this directory may be
+ -- the library directory.
- Data := Projects.Table (Project);
- Extending := Data.Extends /= No_Project;
- Languages := Prj.Util.Value_Of (Name_Languages, Data.Decl.Attributes);
+ if Lib_Src_Dir.Value /= Empty_String then
+ declare
+ Dir_Id : constant Name_Id := Lib_Src_Dir.Value;
- Data.Naming.Current_Language := Name_Ada;
- Data.Sources_Present := Data.Source_Dirs /= Nil_String;
+ begin
+ Locate_Directory
+ (Dir_Id, Data.Display_Directory,
+ Data.Library_Src_Dir,
+ Data.Display_Library_Src_Dir);
- if not Languages.Default then
- declare
- Current : String_List_Id := Languages.Values;
- Element : String_Element;
- Ada_Found : Boolean := False;
+ -- If directory does not exist, report an error
- begin
- Look_For_Ada : while Current /= Nil_String loop
- Element := String_Elements.Table (Current);
- Get_Name_String (Element.Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
+ if Data.Library_Src_Dir = No_Name then
- if Name_Buffer (1 .. Name_Len) = "ada" then
- Ada_Found := True;
- exit Look_For_Ada;
- end if;
+ -- Get the absolute name of the library directory
+ -- that does not exist, to report an error.
- Current := Element.Next;
- end loop Look_For_Ada;
+ declare
+ Dir_Name : constant String :=
+ Get_Name_String (Dir_Id);
- if not Ada_Found then
+ begin
+ if Is_Absolute_Path (Dir_Name) then
+ Err_Vars.Error_Msg_Name_1 := Dir_Id;
- -- Mark the project file as having no sources for Ada
+ else
+ Get_Name_String (Data.Directory);
- Data.Sources_Present := False;
- end if;
- end;
- end if;
-
- Check_Naming_Scheme (Data, Project);
-
- Prepare_Naming_Exceptions (Data.Naming.Bodies, Body_Part);
- Prepare_Naming_Exceptions (Data.Naming.Specs, Specification);
-
- -- If we have source directories, then find the sources
-
- if Data.Sources_Present then
- if Data.Source_Dirs = Nil_String then
- Data.Sources_Present := False;
-
- else
- 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);
-
- Locally_Removed : constant Variable_Value :=
- Util.Value_Of
- (Name_Locally_Removed_Files,
- Data.Decl.Attributes);
+ if Name_Buffer (Name_Len) /=
+ Directory_Separator
+ then
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) :=
+ Directory_Separator;
+ end if;
- begin
- pragma Assert
- (Sources.Kind = List,
- "Source_Files is not a list");
+ Name_Buffer
+ (Name_Len + 1 ..
+ Name_Len + Dir_Name'Length) :=
+ Dir_Name;
+ Name_Len := Name_Len + Dir_Name'Length;
+ Err_Vars.Error_Msg_Name_1 := Name_Find;
+ end if;
- pragma Assert
- (Source_List_File.Kind = Single,
- "Source_List_File is not a single string");
+ -- Report the error
- 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;
+ Error_Msg
+ (Project,
+ "Directory { does not exist",
+ Lib_Src_Dir.Location);
+ end;
- -- Sources is a list of file names
+ -- Report an error if it is the same as the object
+ -- directory.
- declare
- Current : String_List_Id := Sources.Values;
- Element : String_Element;
- Location : Source_Ptr;
- Name : Name_Id;
+ elsif Data.Library_Src_Dir = Data.Object_Directory then
+ Error_Msg
+ (Project,
+ "directory to copy interfaces cannot be " &
+ "the object directory",
+ Lib_Src_Dir.Location);
+ Data.Library_Src_Dir := No_Name;
- begin
- Source_Names.Reset;
+ -- Check if it is the same as one of the source
+ -- directories.
- Data.Sources_Present := Current /= Nil_String;
+ else
+ declare
+ Src_Dirs : String_List_Id := Data.Source_Dirs;
+ Src_Dir : String_Element;
- 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;
+ begin
+ while Src_Dirs /= Nil_String loop
+ Src_Dir := String_Elements.Table (Src_Dirs);
+ Src_Dirs := Src_Dir.Next;
- -- If the element has no location, then use the
- -- location of Sources to report possible errors.
+ -- Report an error if it is one of the
+ -- source directories.
- if Element.Location = No_Location then
- Location := Sources.Location;
+ if Data.Library_Src_Dir = Src_Dir.Value then
+ Error_Msg
+ (Project,
+ "directory to copy interfaces cannot " &
+ "be one of the source directories",
+ Lib_Src_Dir.Location);
+ Data.Library_Src_Dir := No_Name;
+ exit;
+ end if;
+ end loop;
+ end;
- else
- Location := Element.Location;
+ if Data.Library_Src_Dir /= No_Name
+ and then Current_Verbosity = High
+ then
+ Write_Str ("Directory to copy interfaces =""");
+ Write_Str (Get_Name_String (Data.Library_Dir));
+ Write_Line ("""");
end if;
+ end if;
+ end;
+ end if;
- Source_Names.Set
- (K => Name,
- E =>
- (Name => Name,
- Location => Location,
- Found => False));
+ if not Lib_Symbol_File.Default then
+ Data.Symbol_Data.Symbol_File := Lib_Symbol_File.Value;
- Current := Element.Next;
- end loop;
+ Get_Name_String (Lib_Symbol_File.Value);
- Get_Path_Names_And_Record_Sources;
- end;
+ if Name_Len = 0 then
+ Error_Msg
+ (Project,
+ "symbol file name cannot be an empty string",
+ Lib_Symbol_File.Location);
- -- No source_files specified.
- -- We check Source_List_File has been specified.
+ else
+ OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
- elsif not Source_List_File.Default then
+ if OK then
+ for J in 1 .. Name_Len loop
+ if Name_Buffer (J) = '/'
+ or else Name_Buffer (J) = Directory_Separator
+ then
+ OK := False;
+ exit;
+ end if;
+ end loop;
+ end if;
- -- Source_List_File is the name of the file
- -- that contains the source file names
+ if not OK then
+ Error_Msg_Name_1 := Lib_Symbol_File.Value;
+ Error_Msg
+ (Project,
+ "symbol file name { is illegal. " &
+ "Name canot include directory info.",
+ Lib_Symbol_File.Location);
+ end if;
+ end if;
+ end if;
+ if not Lib_Symbol_Policy.Default then
declare
- Source_File_Path_Name : constant String :=
- Path_Name_Of
- (Source_List_File.Value,
- Data.Directory);
+ Value : constant String :=
+ To_Lower
+ (Get_Name_String (Lib_Symbol_Policy.Value));
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);
+ if Value = "autonomous" or else Value = "default" then
+ Data.Symbol_Data.Symbol_Policy := Autonomous;
+
+ elsif Value = "compliant" then
+ Data.Symbol_Data.Symbol_Policy := Compliant;
+
+ elsif Value = "controlled" then
+ Data.Symbol_Data.Symbol_Policy := Controlled;
else
- Get_Sources_From_File
- (Source_File_Path_Name,
- Source_List_File.Location);
+ Error_Msg
+ (Project,
+ "illegal value for Library_Symbol_Policy",
+ Lib_Symbol_Policy.Location);
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.
-
- Find_Sources;
end if;
- -- If there are sources that are locally removed, mark them as
- -- such in the Units table.
+ if Lib_Ref_Symbol_File.Default then
+ if Data.Symbol_Data.Symbol_Policy /= Autonomous then
+ Error_Msg
+ (Project,
+ "a reference symbol file need to be defined",
+ Lib_Symbol_Policy.Location);
+ end if;
- if not Locally_Removed.Default then
- -- Sources can be locally removed only in extending
- -- project files.
+ else
+ Data.Symbol_Data.Reference := Lib_Ref_Symbol_File.Value;
- if Data.Extends = No_Project then
+ Get_Name_String (Lib_Symbol_File.Value);
+
+ if Name_Len = 0 then
Error_Msg
(Project,
- "Locally_Removed_Files can only be used " &
- "in an extending project file",
- Locally_Removed.Location);
+ "reference symbol file name cannot be an empty string",
+ Lib_Symbol_File.Location);
else
- declare
- Current : String_List_Id :=
- Locally_Removed.Values;
- Element : String_Element;
- Location : Source_Ptr;
- OK : Boolean;
- Unit : Unit_Data;
- Name : Name_Id;
- Extended : Project_Id;
-
- begin
- 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;
+ OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
- -- If the element has no location, then use the
- -- location of Locally_Removed to report
- -- possible errors.
+ if OK then
+ for J in 1 .. Name_Len loop
+ if Name_Buffer (J) = '/'
+ or else Name_Buffer (J) = Directory_Separator
+ then
+ OK := False;
+ exit;
+ end if;
+ end loop;
+ end if;
- if Element.Location = No_Location then
- Location := Locally_Removed.Location;
+ if not OK then
+ Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value;
+ Error_Msg
+ (Project,
+ "reference symbol file { name is illegal. " &
+ "Name canot include directory info.",
+ Lib_Ref_Symbol_File.Location);
+ end if;
- else
- Location := Element.Location;
+ if not Is_Regular_File
+ (Get_Name_String (Data.Object_Directory) &
+ Directory_Separator &
+ Get_Name_String (Lib_Ref_Symbol_File.Value))
+ then
+ Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value;
+ Error_Msg
+ (Project,
+ "library reference symbol file { does not exist",
+ Lib_Ref_Symbol_File.Location);
+ end if;
+
+ if Data.Symbol_Data.Symbol_File /= No_Name then
+ declare
+ Symbol : String :=
+ Get_Name_String
+ (Data.Symbol_Data.Symbol_File);
+
+ Reference : String :=
+ Get_Name_String
+ (Data.Symbol_Data.Reference);
+
+ begin
+ Canonical_Case_File_Name (Symbol);
+ Canonical_Case_File_Name (Reference);
+
+ if Symbol = Reference then
+ Error_Msg
+ (Project,
+ "reference symbol file and symbol file " &
+ "cannot be the same file",
+ Lib_Ref_Symbol_File.Location);
end if;
+ end;
+ end if;
+ end if;
+ end if;
+ end if;
+ end Standalone_Library;
+ end if;
- OK := False;
+ -- Put the list of Mains, if any, in the project data
- for Index in 1 .. Units.Last loop
- Unit := Units.Table (Index);
+ Get_Mains (Project, Data);
- if
- Unit.File_Names (Specification).Name = Name
- then
- OK := True;
+ Projects.Table (Project) := Data;
- -- Check that this is from a project that
- -- the current project extends, but not the
- -- current project.
+ Free_Ada_Naming_Exceptions;
+ end Ada_Check;
- Extended := Unit.File_Names
- (Specification).Project;
+ -------------------
+ -- ALI_File_Name --
+ -------------------
- if Extended = Project then
- Error_Msg
- (Project,
- "cannot remove a source " &
- "of the same project",
- Location);
+ function ALI_File_Name (Source : String) return String is
+ begin
+ -- If the source name has an extension, then replace it with
+ -- the ALI suffix.
- elsif
- Project_Extends (Project, Extended)
- then
- Unit.File_Names
- (Specification).Path := Slash;
- Unit.File_Names
- (Specification).Needs_Pragma := False;
- Units.Table (Index) := Unit;
- Add_Forbidden_File_Name
- (Unit.File_Names (Specification).Name);
- exit;
+ for Index in reverse Source'First + 1 .. Source'Last loop
+ if Source (Index) = '.' then
+ return Source (Source'First .. Index - 1) & ALI_Suffix;
+ end if;
+ end loop;
- else
- Error_Msg
- (Project,
- "cannot remove a source from " &
- "another project",
- Location);
- end if;
+ -- If there is no dot, or if it is the first character, just add the
+ -- ALI suffix.
- elsif
- Unit.File_Names (Body_Part).Name = Name
- then
- OK := True;
+ return Source & ALI_Suffix;
+ end ALI_File_Name;
- -- Check that this is from a project that
- -- the current project extends, but not the
- -- current project.
+ --------------------
+ -- Check_Ada_Name --
+ --------------------
- Extended := Unit.File_Names
- (Body_Part).Project;
+ procedure Check_Ada_Name
+ (Name : String;
+ Unit : out Name_Id)
+ is
+ The_Name : String := Name;
+ Real_Name : Name_Id;
+ Need_Letter : Boolean := True;
+ Last_Underscore : Boolean := False;
+ OK : Boolean := The_Name'Length > 0;
- if Extended = Project then
- Error_Msg
- (Project,
- "cannot remove a source " &
- "of the same project",
- Location);
+ begin
+ To_Lower (The_Name);
- elsif
- Project_Extends (Project, Extended)
- then
- Unit.File_Names (Body_Part).Path := Slash;
- Unit.File_Names (Body_Part).Needs_Pragma
- := False;
- Units.Table (Index) := Unit;
- Add_Forbidden_File_Name
- (Unit.File_Names (Body_Part).Name);
- exit;
- end if;
+ Name_Len := The_Name'Length;
+ Name_Buffer (1 .. Name_Len) := The_Name;
+ Real_Name := Name_Find;
- end if;
- end loop;
+ -- Check first that the given name is not an Ada reserved word
- if not OK then
- Err_Vars.Error_Msg_Name_1 := Name;
- Error_Msg (Project, "unknown file {", Location);
- end if;
+ if Get_Name_Table_Byte (Real_Name) /= 0
+ and then Real_Name /= Name_Project
+ and then Real_Name /= Name_Extends
+ and then Real_Name /= Name_External
+ then
+ Unit := No_Name;
- Current := Element.Next;
- end loop;
- end;
- end if;
- end if;
- end;
+ if Current_Verbosity = High then
+ Write_Str (The_Name);
+ Write_Line (" is an Ada reserved word.");
end if;
+
+ return;
end if;
- if Data.Sources_Present then
+ for Index in The_Name'Range loop
+ if Need_Letter then
- -- Check that all individual naming conventions apply to
- -- sources of this project file.
+ -- We need a letter (at the beginning, and following a dot),
+ -- but we don't have one.
- Warn_If_Not_Sources (Data.Naming.Bodies, Specs => False);
- Warn_If_Not_Sources (Data.Naming.Specs, Specs => True);
- end if;
+ if Is_Letter (The_Name (Index)) then
+ Need_Letter := False;
- -- If it is a library project file, check if it is a standalone library
+ else
+ OK := False;
- if Data.Library then
- Standalone_Library : declare
- Lib_Interfaces : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Interface,
- Data.Decl.Attributes);
- Lib_Auto_Init : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Auto_Init,
- Data.Decl.Attributes);
+ if Current_Verbosity = High then
+ Write_Int (Types.Int (Index));
+ Write_Str (": '");
+ Write_Char (The_Name (Index));
+ Write_Line ("' is not a letter.");
+ end if;
- Lib_Src_Dir : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Src_Dir,
- Data.Decl.Attributes);
+ exit;
+ end if;
- Lib_Symbol_File : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Symbol_File,
- Data.Decl.Attributes);
+ elsif Last_Underscore
+ and then (The_Name (Index) = '_' or else The_Name (Index) = '.')
+ then
+ -- Two underscores are illegal, and a dot cannot follow
+ -- an underscore.
- Lib_Symbol_Policy : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Symbol_Policy,
- Data.Decl.Attributes);
+ OK := False;
- Lib_Ref_Symbol_File : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Reference_Symbol_File,
- Data.Decl.Attributes);
+ if Current_Verbosity = High then
+ Write_Int (Types.Int (Index));
+ Write_Str (": '");
+ Write_Char (The_Name (Index));
+ Write_Line ("' is illegal here.");
+ end if;
- Auto_Init_Supported : constant Boolean :=
- MLib.Tgt.
- Standalone_Library_Auto_Init_Is_Supported;
+ exit;
- OK : Boolean := True;
+ elsif The_Name (Index) = '.' then
- begin
- pragma Assert (Lib_Interfaces.Kind = List);
+ -- We need a letter after a dot
- -- It is a stand-alone library project file if attribute
- -- Library_Interface is defined.
+ Need_Letter := True;
- if not Lib_Interfaces.Default then
- declare
- Interfaces : String_List_Id := Lib_Interfaces.Values;
- Interface_ALIs : String_List_Id := Nil_String;
- Unit : Name_Id;
- The_Unit_Id : Unit_Id;
- The_Unit_Data : Unit_Data;
+ elsif The_Name (Index) = '_' then
+ Last_Underscore := True;
- procedure Add_ALI_For (Source : Name_Id);
- -- Add an ALI file name to the list of Interface ALIs
+ else
+ -- We need an letter or a digit
- -----------------
- -- Add_ALI_For --
- -----------------
+ Last_Underscore := False;
- procedure Add_ALI_For (Source : Name_Id) is
- begin
- Get_Name_String (Source);
+ if not Is_Alphanumeric (The_Name (Index)) then
+ OK := False;
- declare
- ALI : constant String :=
- ALI_File_Name (Name_Buffer (1 .. Name_Len));
- ALI_Name_Id : Name_Id;
- begin
- Name_Len := ALI'Length;
- Name_Buffer (1 .. Name_Len) := ALI;
- ALI_Name_Id := Name_Find;
+ if Current_Verbosity = High then
+ Write_Int (Types.Int (Index));
+ Write_Str (": '");
+ Write_Char (The_Name (Index));
+ Write_Line ("' is not alphanumeric.");
+ end if;
- String_Elements.Increment_Last;
- String_Elements.Table (String_Elements.Last) :=
- (Value => ALI_Name_Id,
- Display_Value => ALI_Name_Id,
- Location => String_Elements.Table
- (Interfaces).Location,
- Flag => False,
- Next => Interface_ALIs);
- Interface_ALIs := String_Elements.Last;
- end;
- end Add_ALI_For;
+ exit;
+ end if;
+ end if;
+ end loop;
- begin
- Data.Standalone_Library := True;
+ -- Cannot end with an underscore or a dot
- -- Library_Interface cannot be an empty list
+ OK := OK and then not Need_Letter and then not Last_Underscore;
- if Interfaces = Nil_String then
- Error_Msg
- (Project,
- "Library_Interface cannot be an empty list",
- Lib_Interfaces.Location);
- end if;
+ if OK then
+ Unit := Real_Name;
- -- Process each unit name specified in the attribute
- -- Library_Interface.
+ else
+ -- Signal a problem with No_Name
- while Interfaces /= Nil_String loop
- Get_Name_String
- (String_Elements.Table (Interfaces).Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
+ Unit := No_Name;
+ end if;
+ end Check_Ada_Name;
- if Name_Len = 0 then
- Error_Msg
- (Project,
- "an interface cannot be an empty string",
- String_Elements.Table (Interfaces).Location);
+ ----------------------
+ -- Check_For_Source --
+ ----------------------
- else
- Unit := Name_Find;
- Error_Msg_Name_1 := Unit;
- The_Unit_Id := Units_Htable.Get (Unit);
+ 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;
- if The_Unit_Id = Prj.Com.No_Unit then
- Error_Msg
- (Project,
- "unknown unit {",
- String_Elements.Table (Interfaces).Location);
+ begin
+ Canonical_Case_File_Name (Name);
- else
- -- Check that the unit is part of the project
+ -- 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.
- The_Unit_Data := Units.Table (The_Unit_Id);
+ 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;
- if The_Unit_Data.File_Names
- (Com.Body_Part).Name /= No_Name
- and then The_Unit_Data.File_Names
- (Com.Body_Part).Path /= Slash
- then
- if Check_Project
- (The_Unit_Data.File_Names (Body_Part).Project)
- then
- -- There is a body for this unit.
- -- If there is no spec, we need to check
- -- that it is not a subunit.
+ declare
+ Path : String := Get_Name_String (Path_Name);
- if The_Unit_Data.File_Names
- (Specification).Name = No_Name
- then
- declare
- Src_Ind : Source_File_Index;
+ Path_Id : Name_Id;
+ -- The path name id (in canonical case)
- begin
- Src_Ind := Sinput.P.Load_Project_File
- (Get_Name_String
- (The_Unit_Data.File_Names
- (Body_Part).Path));
+ File_Id : Name_Id;
+ -- The file name id (in canonical case)
- if Sinput.P.Source_File_Is_Subunit
- (Src_Ind)
- then
- Error_Msg
- (Project,
- "{ is a subunit; " &
- "it cannot be an interface",
- String_Elements.Table
- (Interfaces).Location);
- end if;
- end;
- end if;
+ Obj_Id : Name_Id;
+ -- The object file name
- -- The unit is not a subunit, so we add
- -- to the Interface ALIs the ALI file
- -- corresponding to the body.
+ Obj_Path_Id : Name_Id;
+ -- The object path name
- Add_ALI_For
- (The_Unit_Data.File_Names (Body_Part).Name);
+ Dep_Id : Name_Id;
+ -- The dependency file name
- else
- Error_Msg
- (Project,
- "{ is not an unit of this project",
- String_Elements.Table
- (Interfaces).Location);
- end if;
+ Dep_Path_Id : Name_Id;
+ -- The dependency path name
- elsif The_Unit_Data.File_Names
- (Com.Specification).Name /= No_Name
- and then The_Unit_Data.File_Names
- (Com.Specification).Path /= Slash
- and then Check_Project
- (The_Unit_Data.File_Names
- (Specification).Project)
+ Dot_Pos : Natural := 0;
+ -- Position of the last dot in Name
- then
- -- The unit is part of the project, it has
- -- a spec, but no body. We add to the Interface
- -- ALIs the ALI file corresponding to the spec.
+ Source : Other_Source;
+ Source_Id : Other_Source_Id := Data.First_Other_Source;
- Add_ALI_For
- (The_Unit_Data.File_Names (Specification).Name);
+ begin
+ Canonical_Case_File_Name (Path);
- else
- Error_Msg
- (Project,
- "{ is not an unit of this project",
- String_Elements.Table (Interfaces).Location);
- end if;
- end if;
+ -- Get the file name id
- end if;
+ Name_Len := Name'Length;
+ Name_Buffer (1 .. Name_Len) := Name;
+ File_Id := Name_Find;
- Interfaces := String_Elements.Table (Interfaces).Next;
- end loop;
+ -- Get the path name id
- -- Put the list of Interface ALIs in the project data
+ Name_Len := Path'Length;
+ Name_Buffer (1 .. Name_Len) := Path;
+ Path_Id := Name_Find;
- Data.Lib_Interface_ALIs := Interface_ALIs;
+ -- Find the position of the last dot
- -- Check value of attribute Library_Auto_Init and set
- -- Lib_Auto_Init accordingly.
+ for J in reverse Name'Range loop
+ if Name (J) = '.' then
+ Dot_Pos := J;
+ exit;
+ end if;
+ end loop;
- if Lib_Auto_Init.Default then
- -- If no attribute Library_Auto_Init is declared, then
- -- set auto init only if it is supported.
+ if Dot_Pos <= Name'First then
+ Dot_Pos := Name'Last + 1;
+ end if;
- Data.Lib_Auto_Init := Auto_Init_Supported;
+ -- Compute the object file name
- else
- Get_Name_String (Lib_Auto_Init.Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
+ Get_Name_String (File_Id);
+ Name_Len := Dot_Pos - Name'First;
- if Name_Buffer (1 .. Name_Len) = "false" then
- Data.Lib_Auto_Init := False;
+ for J in Object_Suffix'Range loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Object_Suffix (J);
+ end loop;
- elsif Name_Buffer (1 .. Name_Len) = "true" then
- if Auto_Init_Supported then
- Data.Lib_Auto_Init := True;
+ Obj_Id := Name_Find;
- else
- -- Library_Auto_Init cannot be "true" if auto init
- -- is not supported
+ -- Compute the object path name
- Error_Msg
- (Project,
- "library auto init not supported " &
- "on this platform",
- Lib_Auto_Init.Location);
- end if;
+ Get_Name_String (Data.Object_Directory);
- else
- Error_Msg
- (Project,
- "invalid value for attribute Library_Auto_Init",
- Lib_Auto_Init.Location);
- end if;
- end if;
- end;
+ 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;
- -- If attribute Library_Src_Dir is defined and not the
- -- empty string, check if the directory exist and is not
- -- the object directory or one of the source directories.
- -- This is the directory where copies of the interface
- -- sources will be copied. Note that this directory may be
- -- the library directory.
+ Add_Str_To_Name_Buffer (Get_Name_String (Obj_Id));
+ Obj_Path_Id := Name_Find;
- if Lib_Src_Dir.Value /= Empty_String then
- declare
- Dir_Id : constant Name_Id := Lib_Src_Dir.Value;
+ -- Compute the dependency file name
- begin
- Locate_Directory
- (Dir_Id, Data.Display_Directory,
- Data.Library_Src_Dir,
- Data.Display_Library_Src_Dir);
+ 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;
- -- If directory does not exist, report an error
+ -- Compute the dependency path name
- if Data.Library_Src_Dir = No_Name then
+ Get_Name_String (Data.Object_Directory);
- -- Get the absolute name of the library directory
- -- that does not exist, to report an error.
+ 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;
- declare
- Dir_Name : constant String :=
- Get_Name_String (Dir_Id);
+ Add_Str_To_Name_Buffer (Get_Name_String (Dep_Id));
+ Dep_Path_Id := Name_Find;
- begin
- if Is_Absolute_Path (Dir_Name) then
- Err_Vars.Error_Msg_Name_1 := Dir_Id;
+ -- 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.
- else
- Get_Name_String (Data.Directory);
+ while Source_Id /= No_Other_Source loop
+ Source := Other_Sources.Table (Source_Id);
+ Source_Id := Source.Next;
- if Name_Buffer (Name_Len) /=
- Directory_Separator
- then
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) :=
- Directory_Separator;
- end if;
+ if Source.File_Name = File_Id then
+ -- Two sources of different languages cannot have the same
+ -- file name.
- Name_Buffer
- (Name_Len + 1 ..
- Name_Len + Dir_Name'Length) :=
- Dir_Name;
- Name_Len := Name_Len + Dir_Name'Length;
- Err_Vars.Error_Msg_Name_1 := Name_Find;
- end if;
+ if Source.Language /= Language then
+ Error_Msg_Name_1 := File_Name;
+ Error_Msg
+ (Project,
+ "{ cannot be a source of several languages",
+ Real_Location);
+ return;
- -- Report the error
+ -- No problem if a file has already been specified as
+ -- a naming exception of this language.
- Error_Msg
- (Project,
- "Directory { does not exist",
- Lib_Src_Dir.Location);
- end;
+ elsif Source.Path_Name = Path_Id then
+ -- Reset the naming exception flag, if this is not a
+ -- naming exception.
- -- Report an error if it is the same as the object
- -- directory.
+ if not Naming_Exception then
+ Other_Sources.Table (Source_Id).Naming_Exception :=
+ False;
+ end if;
- elsif Data.Library_Src_Dir = Data.Object_Directory then
- Error_Msg
- (Project,
- "directory to copy interfaces cannot be " &
- "the object directory",
- Lib_Src_Dir.Location);
- Data.Library_Src_Dir := No_Name;
+ return;
- -- Check if it is the same as one of the source
- -- directories.
+ -- 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.
- else
- declare
- Src_Dirs : String_List_Id := Data.Source_Dirs;
- Src_Dir : String_Element;
+ elsif Data.Known_Order_Of_Source_Dirs then
+ return;
- begin
- while Src_Dirs /= Nil_String loop
- Src_Dir := String_Elements.Table (Src_Dirs);
- Src_Dirs := Src_Dir.Next;
+ -- But it is an error if the order of the source directories
+ -- is not known.
- -- Report an error if it is one of the
- -- source directories.
+ else
+ Error_Msg_Name_1 := File_Name;
+ Error_Msg
+ (Project,
+ "{ is found in several source directories",
+ Real_Location);
+ return;
+ end if;
- if Data.Library_Src_Dir = Src_Dir.Value then
- Error_Msg
- (Project,
- "directory to copy interfaces cannot " &
- "be one of the source directories",
- Lib_Src_Dir.Location);
- Data.Library_Src_Dir := No_Name;
- exit;
- end if;
- end loop;
- end;
+ -- Two sources with different file names cannot have the same
+ -- object file name.
- if Data.Library_Src_Dir /= No_Name
- and then Current_Verbosity = High
- then
- Write_Str ("Directory to copy interfaces =""");
- Write_Str (Get_Name_String (Data.Library_Dir));
- Write_Line ("""");
- end if;
- end if;
- end;
+ 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 not Lib_Symbol_File.Default then
- Data.Symbol_Data.Symbol_File := Lib_Symbol_File.Value;
+ 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;
- Get_Name_String (Lib_Symbol_File.Value);
+ -- 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;
- if Name_Len = 0 then
- Error_Msg
- (Project,
- "symbol file name cannot be an empty string",
- Lib_Symbol_File.Location);
+ -- And there are sources of this language in this project
- else
- OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
+ Data.Languages (Language) := True;
- if OK then
- for J in 1 .. Name_Len loop
- if Name_Buffer (J) = '/'
- or else Name_Buffer (J) = Directory_Separator
- then
- OK := False;
- exit;
- end if;
- end loop;
- end if;
+ -- Add this source to the list of sources of languages other than
+ -- Ada of the project.
- if not OK then
- Error_Msg_Name_1 := Lib_Symbol_File.Value;
- Error_Msg
- (Project,
- "symbol file name { is illegal. " &
- "Name canot include directory info.",
- Lib_Symbol_File.Location);
- end if;
- end if;
- end if;
+ if Data.First_Other_Source = No_Other_Source then
+ Data.First_Other_Source := Other_Sources.Last;
- if not Lib_Symbol_Policy.Default then
- declare
- Value : constant String :=
- To_Lower
- (Get_Name_String (Lib_Symbol_Policy.Value));
+ else
+ Other_Sources.Table (Data.Last_Other_Source).Next :=
+ Other_Sources.Last;
+ end if;
- begin
- if Value = "autonomous" or else Value = "default" then
- Data.Symbol_Data.Symbol_Policy := Autonomous;
+ Data.Last_Other_Source := Other_Sources.Last;
+ end;
+ end if;
+ end Check_For_Source;
- elsif Value = "compliant" then
- Data.Symbol_Data.Symbol_Policy := Compliant;
+ -----------------------------
+ -- Check_Ada_Naming_Scheme --
+ -----------------------------
- elsif Value = "controlled" then
- Data.Symbol_Data.Symbol_Policy := Controlled;
+ procedure Check_Ada_Naming_Scheme
+ (Project : Project_Id;
+ Naming : Naming_Data)
+ is
+ begin
+ -- Only check if we are not using the standard naming scheme
- else
- Error_Msg
- (Project,
- "illegal value for Library_Symbol_Policy",
- Lib_Symbol_Policy.Location);
- end if;
- end;
- end if;
+ if Naming /= Standard_Naming_Data then
+ declare
+ Dot_Replacement : constant String :=
+ Get_Name_String
+ (Naming.Dot_Replacement);
- if Lib_Ref_Symbol_File.Default then
- if Data.Symbol_Data.Symbol_Policy /= Autonomous then
- Error_Msg
- (Project,
- "a reference symbol file need to be defined",
- Lib_Symbol_Policy.Location);
- end if;
+ Spec_Suffix : constant String :=
+ Get_Name_String
+ (Naming.Current_Spec_Suffix);
- else
- Data.Symbol_Data.Reference := Lib_Ref_Symbol_File.Value;
+ Body_Suffix : constant String :=
+ Get_Name_String
+ (Naming.Current_Body_Suffix);
- Get_Name_String (Lib_Symbol_File.Value);
+ Separate_Suffix : constant String :=
+ Get_Name_String
+ (Naming.Separate_Suffix);
- if Name_Len = 0 then
- Error_Msg
- (Project,
- "reference symbol file name cannot be an empty string",
- Lib_Symbol_File.Location);
+ begin
+ -- Dot_Replacement cannot
+ -- - be empty
+ -- - start or end with an alphanumeric
+ -- - be a single '_'
+ -- - start with an '_' followed by an alphanumeric
+ -- - contain a '.' except if it is "."
- else
- OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
+ if Dot_Replacement'Length = 0
+ or else Is_Alphanumeric
+ (Dot_Replacement (Dot_Replacement'First))
+ or else Is_Alphanumeric
+ (Dot_Replacement (Dot_Replacement'Last))
+ or else (Dot_Replacement (Dot_Replacement'First) = '_'
+ and then
+ (Dot_Replacement'Length = 1
+ or else
+ Is_Alphanumeric
+ (Dot_Replacement (Dot_Replacement'First + 1))))
+ or else (Dot_Replacement'Length > 1
+ and then
+ Index (Source => Dot_Replacement,
+ Pattern => ".") /= 0)
+ then
+ Error_Msg
+ (Project,
+ '"' & Dot_Replacement &
+ """ is illegal for Dot_Replacement.",
+ Naming.Dot_Repl_Loc);
+ end if;
- if OK then
- for J in 1 .. Name_Len loop
- if Name_Buffer (J) = '/'
- or else Name_Buffer (J) = Directory_Separator
- then
- OK := False;
- exit;
- end if;
- end loop;
- end if;
+ -- Suffixes cannot
+ -- - be empty
- if not OK then
- Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value;
- Error_Msg
- (Project,
- "reference symbol file { name is illegal. " &
- "Name canot include directory info.",
- Lib_Ref_Symbol_File.Location);
- end if;
+ if Is_Illegal_Suffix
+ (Spec_Suffix, Dot_Replacement = ".")
+ then
+ Err_Vars.Error_Msg_Name_1 := Naming.Current_Spec_Suffix;
+ Error_Msg
+ (Project,
+ "{ is illegal for Spec_Suffix",
+ Naming.Spec_Suffix_Loc);
+ end if;
- if not Is_Regular_File
- (Get_Name_String (Data.Object_Directory) &
- Directory_Separator &
- Get_Name_String (Lib_Ref_Symbol_File.Value))
- then
- Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value;
- Error_Msg
- (Project,
- "library reference symbol file { does not exist",
- Lib_Ref_Symbol_File.Location);
- end if;
+ if Is_Illegal_Suffix
+ (Body_Suffix, Dot_Replacement = ".")
+ then
+ Err_Vars.Error_Msg_Name_1 := Naming.Current_Body_Suffix;
+ Error_Msg
+ (Project,
+ "{ is illegal for Body_Suffix",
+ Naming.Body_Suffix_Loc);
+ end if;
- if Data.Symbol_Data.Symbol_File /= No_Name then
- declare
- Symbol : String :=
- Get_Name_String
- (Data.Symbol_Data.Symbol_File);
+ if Body_Suffix /= Separate_Suffix then
+ if Is_Illegal_Suffix
+ (Separate_Suffix, Dot_Replacement = ".")
+ then
+ Err_Vars.Error_Msg_Name_1 := Naming.Separate_Suffix;
+ Error_Msg
+ (Project,
+ "{ is illegal for Separate_Suffix",
+ Naming.Sep_Suffix_Loc);
+ end if;
+ end if;
- Reference : String :=
- Get_Name_String
- (Data.Symbol_Data.Reference);
+ -- Spec_Suffix cannot have the same termination as
+ -- Body_Suffix or Separate_Suffix
- begin
- Canonical_Case_File_Name (Symbol);
- Canonical_Case_File_Name (Reference);
+ if Spec_Suffix'Length <= Body_Suffix'Length
+ and then
+ Body_Suffix (Body_Suffix'Last -
+ Spec_Suffix'Length + 1 ..
+ Body_Suffix'Last) = Spec_Suffix
+ then
+ Error_Msg
+ (Project,
+ "Body_Suffix (""" &
+ Body_Suffix &
+ """) cannot end with" &
+ " Spec_Suffix (""" &
+ Spec_Suffix & """).",
+ Naming.Body_Suffix_Loc);
+ end if;
- if Symbol = Reference then
- Error_Msg
- (Project,
- "reference symbol file and symbol file " &
- "cannot be the same file",
- Lib_Ref_Symbol_File.Location);
- end if;
- end;
- end if;
- end if;
- end if;
+ if Body_Suffix /= Separate_Suffix
+ and then Spec_Suffix'Length <= Separate_Suffix'Length
+ and then
+ Separate_Suffix
+ (Separate_Suffix'Last - Spec_Suffix'Length + 1
+ ..
+ Separate_Suffix'Last) = Spec_Suffix
+ then
+ Error_Msg
+ (Project,
+ "Separate_Suffix (""" &
+ Separate_Suffix &
+ """) cannot end with" &
+ " Spec_Suffix (""" &
+ Spec_Suffix & """).",
+ Naming.Sep_Suffix_Loc);
end if;
- end Standalone_Library;
+ end;
end if;
+ end Check_Ada_Naming_Scheme;
- -- 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);
+ -------------------------
+ -- Check_Naming_Scheme --
+ -------------------------
- begin
- Data.Mains := Mains.Values;
+ 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);
- -- If no Mains were specified, and if we are an extending
- -- project, inherit the Mains from the project we are extending.
+ Naming : Package_Element;
- if Mains.Default then
- if Data.Extends /= No_Project then
- Data.Mains := Projects.Table (Data.Extends).Mains;
- end if;
+ procedure Check_Unit_Names (List : Array_Element_Id);
+ -- Check that a list of unit names contains only valid names.
- -- In a library project file, Main cannot be specified
+ ----------------------
+ -- Check_Unit_Names --
+ ----------------------
- elsif Data.Library then
- Error_Msg
- (Project,
- "a library project file cannot have Main specified",
- Mains.Location);
- end if;
- end;
+ procedure Check_Unit_Names (List : Array_Element_Id) is
+ Current : Array_Element_Id := List;
+ Element : Array_Element;
+ Unit_Name : Name_Id;
- Projects.Table (Project) := Data;
+ begin
+ -- Loop through elements of the string list
- Free_Naming_Exceptions;
- end Ada_Check;
+ while Current /= No_Array_Element loop
+ Element := Array_Elements.Table (Current);
- -------------------
- -- ALI_File_Name --
- -------------------
+ -- Put file name in canonical case
- function ALI_File_Name (Source : String) return String is
- begin
- -- If the source name has an extension, then replace it with
- -- the ALI suffix.
+ Get_Name_String (Element.Value.Value);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Element.Value.Value := Name_Find;
- for Index in reverse Source'First + 1 .. Source'Last loop
- if Source (Index) = '.' then
- return Source (Source'First .. Index - 1) & ALI_Suffix;
- end if;
- end loop;
+ -- Check that it contains a valid unit name
- -- If there is no dot, or if it is the first character, just add the
- -- ALI suffix.
+ Get_Name_String (Element.Index);
+ Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit_Name);
- return Source & ALI_Suffix;
- end ALI_File_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);
- --------------------
- -- Check_Ada_Name --
- --------------------
+ else
+ if Current_Verbosity = High then
+ Write_Str (" Unit (""");
+ Write_Str (Get_Name_String (Unit_Name));
+ Write_Line (""")");
+ end if;
- procedure Check_Ada_Name
- (Name : String;
- Unit : out Name_Id)
- is
- The_Name : String := Name;
- Real_Name : Name_Id;
- Need_Letter : Boolean := True;
- Last_Underscore : Boolean := False;
- OK : Boolean := The_Name'Length > 0;
+ Element.Index := Unit_Name;
+ Array_Elements.Table (Current) := Element;
+ end if;
- begin
- To_Lower (The_Name);
+ Current := Element.Next;
+ end loop;
+ end Check_Unit_Names;
- Name_Len := The_Name'Length;
- Name_Buffer (1 .. Name_Len) := The_Name;
- Real_Name := Name_Find;
+ -- Start of processing for Check_Naming_Scheme
- -- Check first that the given name is not an Ada reserved word
+ begin
+ -- If there is a package Naming, we will put in Data.Naming what is in
+ -- this package Naming.
- if Get_Name_Table_Byte (Real_Name) /= 0
- and then Real_Name /= Name_Project
- and then Real_Name /= Name_Extends
- and then Real_Name /= Name_External
- then
- Unit := No_Name;
+ if Naming_Id /= No_Package then
+ Naming := Packages.Table (Naming_Id);
if Current_Verbosity = High then
- Write_Str (The_Name);
- Write_Line (" is an Ada reserved word.");
+ Write_Line ("Checking ""Naming"" for Ada.");
end if;
- return;
- end if;
-
- for Index in The_Name'Range loop
- if Need_Letter then
+ declare
+ Bodies : constant Array_Element_Id :=
+ Util.Value_Of (Name_Body, Naming.Decl.Arrays);
- -- We need a letter (at the beginning, and following a dot),
- -- but we don't have one.
+ Specs : constant Array_Element_Id :=
+ Util.Value_Of (Name_Spec, Naming.Decl.Arrays);
- if Is_Letter (The_Name (Index)) then
- Need_Letter := False;
+ begin
+ if Bodies /= No_Array_Element then
- else
- OK := False;
+ -- We have elements in the array Body_Part
if Current_Verbosity = High then
- Write_Int (Types.Int (Index));
- Write_Str (": '");
- Write_Char (The_Name (Index));
- Write_Line ("' is not a letter.");
+ Write_Line ("Found Bodies.");
end if;
- exit;
+ Data.Naming.Bodies := Bodies;
+ Check_Unit_Names (Bodies);
+
+ else
+ if Current_Verbosity = High then
+ Write_Line ("No Bodies.");
+ end if;
end if;
- elsif Last_Underscore
- and then (The_Name (Index) = '_' or else The_Name (Index) = '.')
- then
- -- Two underscores are illegal, and a dot cannot follow
- -- an underscore.
+ if Specs /= No_Array_Element then
- OK := False;
+ -- We have elements in the array Specs
- if Current_Verbosity = High then
- Write_Int (Types.Int (Index));
- Write_Str (": '");
- Write_Char (The_Name (Index));
- Write_Line ("' is illegal here.");
- end if;
+ if Current_Verbosity = High then
+ Write_Line ("Found Specs.");
+ end if;
- exit;
+ Data.Naming.Specs := Specs;
+ Check_Unit_Names (Specs);
- elsif The_Name (Index) = '.' then
+ else
+ if Current_Verbosity = High then
+ Write_Line ("No Specs.");
+ end if;
+ end if;
+ end;
- -- We need a letter after a dot
+ -- We are now checking if variables Dot_Replacement, Casing,
+ -- Spec_Suffix, Body_Suffix and/or Separate_Suffix
+ -- exist.
- Need_Letter := True;
+ -- For each variable, if it does not exist, we do nothing,
+ -- because we already have the default.
- elsif The_Name (Index) = '_' then
- Last_Underscore := True;
+ -- Check Dot_Replacement
- else
- -- We need an letter or a digit
+ declare
+ Dot_Replacement : constant Variable_Value :=
+ Util.Value_Of
+ (Name_Dot_Replacement,
+ Naming.Decl.Attributes);
- Last_Underscore := False;
+ begin
+ pragma Assert (Dot_Replacement.Kind = Single,
+ "Dot_Replacement is not a single string");
- if not Is_Alphanumeric (The_Name (Index)) then
- OK := False;
+ if not Dot_Replacement.Default then
+ Get_Name_String (Dot_Replacement.Value);
- if Current_Verbosity = High then
- Write_Int (Types.Int (Index));
- Write_Str (": '");
- Write_Char (The_Name (Index));
- Write_Line ("' is not alphanumeric.");
- end if;
+ if Name_Len = 0 then
+ Error_Msg
+ (Project,
+ "Dot_Replacement cannot be empty",
+ Dot_Replacement.Location);
- exit;
+ 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;
- end loop;
- -- Cannot end with an underscore or a dot
+ -- Check Casing
- OK := OK and then not Need_Letter and then not Last_Underscore;
+ declare
+ Casing_String : constant Variable_Value :=
+ Util.Value_Of
+ (Name_Casing, Naming.Decl.Attributes);
- if OK then
- Unit := Real_Name;
+ begin
+ pragma Assert (Casing_String.Kind = Single,
+ "Casing is not a single string");
- else
- -- Signal a problem with No_Name
+ 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.
- Unit := No_Name;
- end if;
- end Check_Ada_Name;
+ if not File_Names_Case_Sensitive then
+ Data.Naming.Casing := All_Lower_Case;
- -----------------------------
- -- Check_Ada_Naming_Scheme --
- -----------------------------
+ else
+ Data.Naming.Casing := Casing_Value;
+ end if;
+ end;
- procedure Check_Ada_Naming_Scheme
- (Project : Project_Id;
- Naming : Naming_Data)
- is
- begin
- -- Only check if we are not using the standard naming scheme
+ exception
+ when Constraint_Error =>
+ if Casing_Image'Length = 0 then
+ Error_Msg
+ (Project,
+ "Casing cannot be an empty string",
+ Casing_String.Location);
- if Naming /= Standard_Naming_Data then
- declare
- Dot_Replacement : constant String :=
- Get_Name_String
- (Naming.Dot_Replacement);
+ 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;
- Spec_Suffix : constant String :=
- Get_Name_String
- (Naming.Current_Spec_Suffix);
+ if Current_Verbosity = High then
+ Write_Str (" Casing = ");
+ Write_Str (Image (Data.Naming.Casing));
+ Write_Char ('.');
+ Write_Eol;
+ end if;
- Body_Suffix : constant String :=
- Get_Name_String
- (Naming.Current_Body_Suffix);
+ -- Check Spec_Suffix
- Separate_Suffix : constant String :=
- Get_Name_String
- (Naming.Separate_Suffix);
+ declare
+ Ada_Spec_Suffix : constant Variable_Value :=
+ Prj.Util.Value_Of
+ (Index => Name_Ada,
+ In_Array => Data.Naming.Spec_Suffix);
begin
- -- Dot_Replacement cannot
- -- - be empty
- -- - start or end with an alphanumeric
- -- - be a single '_'
- -- - start with an '_' followed by an alphanumeric
- -- - contain a '.' except if it is "."
+ 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;
- if Dot_Replacement'Length = 0
- or else Is_Alphanumeric
- (Dot_Replacement (Dot_Replacement'First))
- or else Is_Alphanumeric
- (Dot_Replacement (Dot_Replacement'Last))
- or else (Dot_Replacement (Dot_Replacement'First) = '_'
- and then
- (Dot_Replacement'Length = 1
- or else
- Is_Alphanumeric
- (Dot_Replacement (Dot_Replacement'First + 1))))
- or else (Dot_Replacement'Length > 1
- and then
- Index (Source => Dot_Replacement,
- Pattern => ".") /= 0)
+ 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
- Error_Msg
- (Project,
- '"' & Dot_Replacement &
- """ is illegal for Dot_Replacement.",
- Naming.Dot_Repl_Loc);
+ 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;
- -- Suffixes cannot
- -- - be empty
+ -- Check Separate_Suffix
- if Is_Illegal_Suffix
- (Spec_Suffix, Dot_Replacement = ".")
- then
- Err_Vars.Error_Msg_Name_1 := Naming.Current_Spec_Suffix;
- Error_Msg
- (Project,
- "{ is illegal for Spec_Suffix",
- Naming.Spec_Suffix_Loc);
- end if;
+ declare
+ Ada_Sep_Suffix : constant Variable_Value :=
+ Prj.Util.Value_Of
+ (Variable_Name => Name_Separate_Suffix,
+ In_Variables => Naming.Decl.Attributes);
- if Is_Illegal_Suffix
- (Body_Suffix, Dot_Replacement = ".")
- then
- Err_Vars.Error_Msg_Name_1 := Naming.Current_Body_Suffix;
- Error_Msg
- (Project,
- "{ is illegal for Body_Suffix",
- Naming.Body_Suffix_Loc);
- end if;
+ begin
+ if Ada_Sep_Suffix.Default then
+ Data.Naming.Separate_Suffix :=
+ Data.Naming.Current_Body_Suffix;
- if Body_Suffix /= Separate_Suffix then
- if Is_Illegal_Suffix
- (Separate_Suffix, Dot_Replacement = ".")
- then
- Err_Vars.Error_Msg_Name_1 := Naming.Separate_Suffix;
+ else
+ Get_Name_String (Ada_Sep_Suffix.Value);
+
+ if Name_Len = 0 then
Error_Msg
(Project,
- "{ is illegal for Separate_Suffix",
- Naming.Sep_Suffix_Loc);
+ "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;
- -- Spec_Suffix cannot have the same termination as
- -- Body_Suffix or Separate_Suffix
+ if Current_Verbosity = High then
+ Write_Str (" Separate_Suffix = """);
+ Write_Str (Get_Name_String (Data.Naming.Separate_Suffix));
+ Write_Char ('"');
+ Write_Eol;
+ end if;
- if Spec_Suffix'Length <= Body_Suffix'Length
- and then
- Body_Suffix (Body_Suffix'Last -
- Spec_Suffix'Length + 1 ..
- Body_Suffix'Last) = Spec_Suffix
- then
- Error_Msg
- (Project,
- "Body_Suffix (""" &
- Body_Suffix &
- """) cannot end with" &
- " Spec_Suffix (""" &
- Spec_Suffix & """).",
- Naming.Body_Suffix_Loc);
- end if;
+ -- Check if Data.Naming is valid
- if Body_Suffix /= Separate_Suffix
- and then Spec_Suffix'Length <= Separate_Suffix'Length
- and then
- Separate_Suffix
- (Separate_Suffix'Last - Spec_Suffix'Length + 1
- ..
- Separate_Suffix'Last) = Spec_Suffix
- then
- Error_Msg
- (Project,
- "Separate_Suffix (""" &
- Separate_Suffix &
- """) cannot end with" &
- " Spec_Suffix (""" &
- Spec_Suffix & """).",
- Naming.Sep_Suffix_Loc);
- end if;
+ 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;
- end Check_Ada_Naming_Scheme;
+
+ 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 --
-- Warning character. It is always the first one in this package
- First := First + 1;
- Add ("Warning: ");
+ First := First + 1;
+ Add ("Warning: ");
+ end if;
+
+ for Index in First .. Msg'Last loop
+ if Msg (Index) = '{' or else Msg (Index) = '%' then
+
+ -- Include a name between double quotes.
+
+ Msg_Name := Msg_Name + 1;
+ Add ('"');
+
+ case Msg_Name is
+ when 1 => Add (Err_Vars.Error_Msg_Name_1);
+ when 2 => Add (Err_Vars.Error_Msg_Name_2);
+ when 3 => Add (Err_Vars.Error_Msg_Name_3);
+
+ when others => null;
+ end case;
+
+ Add ('"');
+
+ else
+ Add (Msg (Index));
+ end if;
+
+ end loop;
+
+ 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;
- for Index in First .. Msg'Last loop
- if Msg (Index) = '{' or else Msg (Index) = '%' then
-
- -- Include a name between double quotes.
+ -- Open the file
- Msg_Name := Msg_Name + 1;
- Add ('"');
+ Prj.Util.Open (File, Path);
- case Msg_Name is
- when 1 => Add (Err_Vars.Error_Msg_Name_1);
- when 2 => Add (Err_Vars.Error_Msg_Name_2);
- when 3 => Add (Err_Vars.Error_Msg_Name_3);
+ if not Prj.Util.Is_Valid (File) then
+ Error_Msg (Project, "file does not exist", Location);
+ else
+ -- Read the lines one by one
- when others => null;
- end case;
+ while not Prj.Util.End_Of_File (File) loop
+ Prj.Util.Get_Line (File, Line, Last);
- Add ('"');
+ -- A non empty, non comment line should contain a file name
- else
- Add (Msg (Index));
- end if;
+ 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;
- end loop;
+ Prj.Util.Close (File);
- Error_Report (Error_Buffer (1 .. Error_Last), Project);
- end Error_Msg;
+ end if;
+ end Get_Sources_From_File;
--------------
-- Get_Unit --
---------------------
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
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
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 --
-----------------------
Element := Array_Elements.Table (Current);
Get_Name_String (Element.Value.Value);
- if Name_Len = 0 then
- Error_Msg
- (Project,
- "Body_Suffix cannot be empty",
- Element.Value.Location);
- end if;
+ if Name_Len = 0 then
+ Error_Msg
+ (Project,
+ "Body_Suffix cannot be empty",
+ Element.Value.Location);
+ end if;
+
+ Array_Elements.Table (Current) := Element;
+ Current := Element.Next;
+ end loop;
+ end;
+
+ -- Get the exceptions, if any
+
+ Data.Naming.Specification_Exceptions :=
+ Util.Value_Of
+ (Name_Specification_Exceptions,
+ In_Arrays => Naming.Decl.Arrays);
+
+ Data.Naming.Implementation_Exceptions :=
+ Util.Value_Of
+ (Name_Implementation_Exceptions,
+ In_Arrays => Naming.Decl.Arrays);
+ end if;
+ end;
+
+ Projects.Table (Project) := Data;
+ end Language_Independent_Check;
+
+ ----------------------
+ -- Locate_Directory --
+ ----------------------
+
+ procedure Locate_Directory
+ (Name : Name_Id;
+ Parent : Name_Id;
+ Dir : out Name_Id;
+ Display : out Name_Id)
+ is
+ The_Name : constant String := Get_Name_String (Name);
+ The_Parent : constant String :=
+ Get_Name_String (Parent) & Directory_Separator;
+ The_Parent_Last : constant Natural :=
+ Compute_Directory_Last (The_Parent);
+
+ begin
+ if Current_Verbosity = High then
+ Write_Str ("Locate_Directory (""");
+ Write_Str (The_Name);
+ Write_Str (""", """);
+ Write_Str (The_Parent);
+ Write_Line (""")");
+ end if;
+
+ Dir := No_Name;
+ Display := No_Name;
+
+ if Is_Absolute_Path (The_Name) then
+ if Is_Directory (The_Name) then
+ declare
+ Normed : constant String :=
+ Normalize_Pathname
+ (The_Name,
+ Resolve_Links => False,
+ Case_Sensitive => True);
+
+ Canonical_Path : constant String :=
+ Normalize_Pathname
+ (Normed,
+ Resolve_Links => True,
+ Case_Sensitive => False);
+
+ begin
+ Name_Len := Normed'Length;
+ Name_Buffer (1 .. Name_Len) := Normed;
+ Display := Name_Find;
+
+ Name_Len := Canonical_Path'Length;
+ Name_Buffer (1 .. Name_Len) := Canonical_Path;
+ Dir := Name_Find;
+ end;
+ end if;
+
+ else
+ declare
+ Full_Path : constant String :=
+ The_Parent (The_Parent'First .. The_Parent_Last) &
+ The_Name;
+
+ begin
+ if Is_Directory (Full_Path) then
+ declare
+ Normed : constant String :=
+ Normalize_Pathname
+ (Full_Path,
+ Resolve_Links => False,
+ Case_Sensitive => True);
+
+ Canonical_Path : constant String :=
+ Normalize_Pathname
+ (Normed,
+ Resolve_Links => True,
+ Case_Sensitive => False);
+
+ begin
+ Name_Len := Normed'Length;
+ Name_Buffer (1 .. Name_Len) := Normed;
+ Display := Name_Find;
+
+ Name_Len := Canonical_Path'Length;
+ Name_Buffer (1 .. Name_Len) := Canonical_Path;
+ Dir := Name_Find;
+ end;
+ end if;
+ end;
+ 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.
- Array_Elements.Table (Current) := Element;
- Current := Element.Next;
- end loop;
- end;
+ if Element.Location = No_Location then
+ Location := Sources.Location;
- -- Get the exceptions, if any
+ else
+ Location := Element.Location;
+ end if;
- Data.Naming.Specification_Exceptions :=
- Util.Value_Of
- (Name_Specification_Exceptions,
- In_Arrays => Naming.Decl.Arrays);
+ Source_Names.Set
+ (K => Name,
+ E =>
+ (Name => Name,
+ Location => Location,
+ Found => False));
- Data.Naming.Implementation_Exceptions :=
- Util.Value_Of
- (Name_Implementation_Exceptions,
- In_Arrays => Naming.Decl.Arrays);
- end if;
- end;
+ Current := Element.Next;
+ end loop;
- Projects.Table (Project) := Data;
- end Language_Independent_Check;
+ -- And look for their directories
- ----------------------
- -- Locate_Directory --
- ----------------------
+ Record_Other_Sources
+ (Project => Project,
+ Data => Data,
+ Language => Lang,
+ Naming_Exceptions => False);
+ end;
- procedure Locate_Directory
- (Name : Name_Id;
- Parent : Name_Id;
- Dir : out Name_Id;
- Display : out Name_Id)
- is
- The_Name : constant String := Get_Name_String (Name);
- The_Parent : constant String :=
- Get_Name_String (Parent) & Directory_Separator;
- The_Parent_Last : constant Natural :=
- Compute_Directory_Last (The_Parent);
+ -- No source_files specified.
+ -- We check if Source_List_File has been specified.
- begin
- if Current_Verbosity = High then
- Write_Str ("Locate_Directory (""");
- Write_Str (The_Name);
- Write_Str (""", """);
- Write_Str (The_Parent);
- Write_Line (""")");
- end if;
+ elsif not Source_List_File.Default then
- Dir := No_Name;
- Display := No_Name;
+ -- Source_List_File is the name of the file
+ -- that contains the source file names
- if Is_Absolute_Path (The_Name) then
- if Is_Directory (The_Name) then
- declare
- Normed : constant String :=
- Normalize_Pathname
- (The_Name,
- Resolve_Links => False,
- Case_Sensitive => True);
+ declare
+ Source_File_Path_Name : constant String :=
+ Path_Name_Of
+ (Source_List_File.Value,
+ Data.Directory);
- Canonical_Path : constant String :=
- Normalize_Pathname
- (Normed,
- Resolve_Links => True,
- Case_Sensitive => False);
+ 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);
- begin
- Name_Len := Normed'Length;
- Name_Buffer (1 .. Name_Len) := Normed;
- Display := Name_Find;
+ else
+ -- Read the file, putting each source in the
+ -- Source_Names hash table.
- Name_Len := Canonical_Path'Length;
- Name_Buffer (1 .. Name_Len) := Canonical_Path;
- Dir := Name_Find;
- end;
- end if;
+ Get_Sources_From_File
+ (Source_File_Path_Name,
+ Source_List_File.Location,
+ Project);
- else
- declare
- Full_Path : constant String :=
- The_Parent (The_Parent'First .. The_Parent_Last) &
- The_Name;
+ -- And look for their directories.
- begin
- if Is_Directory (Full_Path) then
- declare
- Normed : constant String :=
- Normalize_Pathname
- (Full_Path,
- Resolve_Links => False,
- Case_Sensitive => True);
+ Record_Other_Sources
+ (Project => Project,
+ Data => Data,
+ Language => Lang,
+ Naming_Exceptions => False);
+ end if;
+ end;
- Canonical_Path : constant String :=
- Normalize_Pathname
- (Normed,
- Resolve_Links => True,
- Case_Sensitive => False);
+ 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.
- begin
- Name_Len := Normed'Length;
- Name_Buffer (1 .. Name_Len) := Normed;
- Display := Name_Find;
+ Find_Sources (Project, Data, Lang);
+ end if;
- Name_Len := Canonical_Path'Length;
- Name_Buffer (1 .. Name_Len) := Canonical_Path;
- Dir := Name_Find;
end;
end if;
- end;
+ end loop;
end if;
- end Locate_Directory;
+
+ -- Finally, get the mains, if any
+
+ Get_Mains (Project, Data);
+
+ Projects.Table (Project) := Data;
+
+ end Other_Languages_Check;
------------------
-- Path_Name_Of --
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 --
---------------------
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;
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;
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;
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
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 --
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;
-- --
------------------------------------------------------------------------------
--- 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
-- 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.
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.
-- --
-- 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- --
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;
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;
(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
-- --
-- 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- --
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
-- 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 --
-- 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
Projects.Table (Index).Checked := False;
end loop;
- Recursive_Check (Project, Trusted_Mode);
+ Recursive_Check (Project, Process_Languages, Follow_Links);
+
end Check;
----------------
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;
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
-- 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;
-- 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
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;
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;
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;
-- --
-- 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- --
-------------------
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);
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
-- 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
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
function Value_Of
(Variable : Variable_Value;
- Default : String)
- return String
+ Default : String) return String
is
begin
if Variable.Kind /= Single
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;
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;
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;
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;
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;
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;
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;
-- --
-- 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- --
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
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
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.
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
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.
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 :=
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,
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,
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;
-- --
-- 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- --
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).
-- 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.
-- 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.
System_Pack_63,
System_Parameters,
System_Partition_Interface,
+ System_PolyORB_Interface,
System_Pool_Global,
System_Pool_Empty,
System_Pool_Local,
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_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
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,
-- --
-- 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- --
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
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;
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;
-- --
-- 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- --
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
-- --
-- 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- --
(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
(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.
-- --
-- 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- --
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
-- --
-- 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- --
(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
(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.
-- --
-- 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- --
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
-- --
-- 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- --
(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
-- --
-- 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- --
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
-- --
-- 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- --
-- --
-- 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- --
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
-- --
-- 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- --
(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
-- --
-- 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- --
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
-- --
-- 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- --
(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
-- --
-- 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- --
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
-- --
-- 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- --
(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
-- --
-- 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- --
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
-- --
-- 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- --
(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
-- --
-- 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- --
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;
-- 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- --
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 --
-----------
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 --
-------------------------------------
-- --
-- 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- --
(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);
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
-- 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;
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));
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;
(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;
(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;
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 --
-------------------------------
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;
-- 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);
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
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
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))
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));
("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));
Find_Type (S);
Check_Incomplete (S);
- -- Ada 0Y (AI-231)
+ -- Ada 0Y (AI-231): Static check
if Extensions_Allowed
and then Present (Parent (S))
-- --
-- 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- --
-- 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
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;
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
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;
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
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
-- 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
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.
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));
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 --
------------------------
RS_Pkg_E : Entity_Id;
RAS_Type : Entity_Id;
Async_E : Entity_Id;
- Subp_Id : Int;
Attribute_Subp : Entity_Id;
Parameter : Node_Id;
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
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);
-- --
-- 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- --
-- 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
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
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
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
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
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
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
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
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
-- --
-- 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- --
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
if Nkind (Operand) = N_Raise_Constraint_Error then
Set_Raises_Constraint_Error (N);
end if;
+
return;
end if;
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
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.
-- 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
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)
-- [,[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) := (
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;
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;
--------------------------
-- 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.
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");
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 --
--------------------
-- --
-- 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- --
-- 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.
-- 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,
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
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
-- 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
-- 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 --
-- 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
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
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
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);
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);
"finalize#" &
"next#" &
"prev#" &
+ "_typecode#" &
+ "_from_any#" &
+ "_to_any#" &
"allocate#" &
"deallocate#" &
"dereference#" &
"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#" &
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.
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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.
-- 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
-- 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;
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 =>
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' =>
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:
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. */
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
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;
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;
}
}
/* 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;
}
}
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
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;
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;
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;
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);
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);
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:
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 ();
}
-- --
-- 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- --
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,
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 ..
* *
* 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- *
#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
&& 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 ();
}
}
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);
projects / platform / upstream / gcc.git / commitdiff