+2004-03-02 Emmanuel Briot <briot@act-europe.fr>
+
+ * ali.adb (Read_Instantiation_Instance): Do not modify the
+ current_file_num when reading information about instantiations, since
+ this corrupts files in later references.
+
+2004-03-02 Vincent Celier <celier@gnat.com>
+
+ * bcheck.adb (Check_Consistency): Get the full path of an ALI file
+ before checking if it is read-only.
+
+ * bld.adb (Recursive_Process): Concatenate <PROJECT>.src_dirs in front
+ of SRC_DIRS and eliminate duplicates.
+
+ * gprcmd.adb: Replace command "path" with command "path_sep" to return
+ the path separator.
+ (Usage): Document path_sep
+
+ * Makefile.generic: For Ada and GNU C++ cases, link directly with the
+ C++ compiler. No need for a script.
+ Replace use of C*_INCLUDE_PATH env var for GCC compilers with CPATH.
+ Do not call gprcmd to build the C*_INCLUDE_PATHs, do it with function
+ subst.
+
+ * prj-env.adb (For_All_Source_Dirs): Only add source dirs in project
+ where there are Ada sources.
+ (Set_Ada_Paths): Only add to the include path the source dirs of project
+ with Ada sources.
+ (Add_To_Path): Add the Display_Values of the directories, not their
+ Values.
+
+ * prj-nmsc.adb (Find_Sources): Set flag Sources_Present in the project
+ data.
+
+ * prj-nmsc.adb (Add_ALI_For): Make sure that the element Display_Value
+ is not No_Name.
+ (Find_Source_Dirs): Set Display_Value to a non canonicalized value, only
+ Value is canonicalized.
+ (Language_Independent_Check): Do not copy Value to Display_Value when
+ canonicalizing Value.
+
+ * prj-part.adb (Post_Parse_Context_Clause): Compare canonical cased
+ path to find limited with cycles.
+ (Parse_Single_Project): Use canonical cased path to find the end of a
+ with cycle.
+
+2004-03-02 Ed Schonberg <schonberg@gnat.com>
+
+ * sem_ch10.adb (Optional_Subunit): Verify that unit contains a subunit
+ and not a child unit.
+
+ * sinfo.ads, sinfo.adb: Rearrange flags so that Private_Present can
+ appear in a with_clause.
+
+ * decl.c (gnat_to_gnu_type): If entity is a generic type, which can
+ only happen in type_annotate mode, do not try to elaborate it.
+
+ * exp_util.adb (Force_Evaluation): If expression is a selected
+ component on the left of an assignment, use a renaming rather than a
+ temporary to remove side effects.
+
+ * freeze.adb (Freeze_Entity): Do not freeze a global entity within an
+ inlined instance body, which is analyzed before the end of the
+ enclosing scope.
+
+2004-03-02 Robert Dewar <dewar@gnat.com>
+
+ * par-ch10.adb, par-ch3.adb, par-ch4.adb, scng.adb,
+ sem_ch4.adb: Use new feature for substitution of keywords in VMS
+
+ * errout.ads, errout.adb: Implement new circuit for substitution of
+ keywords in VMS.
+
+ * sem_case.adb (Analyze_Choices): Place message properly when case is
+ a subtype reference rather than an explicit range.
+
+ * sem_elim.adb, s-tpobop.ads, exp_ch2.adb: Minor reformatting
+
+2004-03-02 Doug Rupp <rupp@gnat.com>
+
+ * init.c (__gnat_initialize)[VMS]: Resignal RDB-E-STREAM_EOF.
+
+2004-03-02 Thomas Quinot <quinot@act-europe.fr>
+
+ * s-tporft.adb: Add missing locking around call to Initialize_ATCB.
+
+2004-03-02 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
+
+ * utils.c (finish_record_type): Do not set DECL_NONADDRESSABLE for a
+ BLKmode bitfield.
+
2004-02-25 Robert Dewar <dewar@gnat.com>
* 51osinte.ads, 52osinte.ads, 53osinte.ads, 54osinte.ads,
ifeq ($(filter ada,$(LANGUAGES)),ada)
# C++ and Ada mixed
- LINKER = $(OBJ_DIR)/c++linker
LARGS = --LINK=$(LINKER)
ifeq ($(strip $(filter-out %gcc %g++,$(CXX))),)
- # Case of GNU C++ and GNAT
-
-$(LINKER): Makefile.$(PROJECT_BASE)
- @echo \#!/bin/sh > $(LINKER)
- @echo unset BINUTILS_ROOT >> $(LINKER)
- @echo unset GCC_ROOT >> $(LINKER)
- @echo $(CXX) $$\* >> $(LINKER)
- @chmod +x $(LINKER)
+ # Case of GNAT and a GNU C++ compiler
+$(LINKER):
else
+ # Case of GNAT and a non GNU C++ compiler
+ LINKER = $(OBJ_DIR)/c++linker
+
$(LINKER): Makefile.$(PROJECT_BASE)
@echo \#!/bin/sh > $(LINKER)
@echo $(CXX) $$\* $(shell gcc -print-libgcc-file-name) >> $(LINKER)
ifeq ($(strip $(filter-out %gcc %g++,$(CC) $(CXX))),)
# Compiler is GCC, take avantage of the preprocessor option -MD and
-# C*_INCLUDE_PATH environment variables
+# the CPATH environment variable
-export C_INCLUDE_PATH:=$(shell gprcmd path $(SRC_DIRS))$(C_INCLUDE_PATH)
-export CXX_INCLUDE_PATH:=$(shell gprcmd path $(SRC_DIRS))$(CXX_INCLUDE_PATH)
+empty:=
+space:=$(empty) $(empty)
+path_sep:=$(shell gprcmd path_sep)
+SRC_DIRS_PATH:= $(subst $(space),$(path_sep),$(SRC_DIRS))
+export CPATH:=$(SRC_DIRS_PATH)$(path_sep)$(CPATH)
DEP_CFLAGS = -Wp,-MD,$(OBJ_DIR)/$(*F).d
----------------------------------
procedure Read_Instantiation_Reference is
+ Local_File_Num : Sdep_Id := Current_File_Num;
+
begin
Xref.Increment_Last;
if Nextc = '|' then
XR.File_Num :=
Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
- Current_File_Num := XR.File_Num;
+ Local_File_Num := XR.File_Num;
P := P + 1;
N := Get_Nat;
else
- XR.File_Num := Current_File_Num;
+ XR.File_Num := Local_File_Num;
end if;
XR.Line := N;
Src : Source_Id;
-- Source file Id for this Sdep entry
+ ALI_Path_Id : Name_Id;
+
begin
-- First, we go through the source table to see if there are any cases
-- in which we should go after source files and compute checksums of
end if;
else
- if Osint.Is_Readonly_Library (ALIs.Table (A).Afile) then
- Error_Msg_Name_2 :=
- Osint.Find_File ((ALIs.Table (A).Afile), Osint.Library);
-
+ ALI_Path_Id :=
+ Osint.Find_File ((ALIs.Table (A).Afile), Osint.Library);
+ if Osint.Is_Readonly_Library (ALI_Path_Id) then
if Tolerate_Consistency_Errors then
Error_Msg ("?% should be recompiled");
- Error_Msg_Name_1 := Error_Msg_Name_2;
+ Error_Msg_Name_1 := ALI_Path_Id;
Error_Msg ("?(% is obsolete and read-only)");
else
Error_Msg ("% must be compiled");
- Error_Msg_Name_1 := Error_Msg_Name_2;
+ Error_Msg_Name_1 := ALI_Path_Id;
Error_Msg ("(% is obsolete and read-only)");
end if;
end if;
end if;
- -- Add source dirs of this project file to variable SRC_DIRS
+ -- Add source dirs of this project file to variable SRC_DIRS.
+ -- Put them in front, and remove duplicates.
- Put ("SRC_DIRS:=$(SRC_DIRS) $(");
+ Put ("SRC_DIRS:=$(");
Put (Uname);
- Put (".src_dirs)");
+ Put (".src_dirs) $(filter-out $(");
+ Put (Uname);
+ Put (".src_dirs),$(SRC_DIRS))");
New_Line;
-- Set OBJ_DIR to the object directory
{
tree gnu_decl;
+ /* The back end never attempts to annotate generic types */
+ if (Is_Generic_Type (gnat_entity) && type_annotate_only)
+ return void_type_node;
+
/* Convert the ada entity type into a GCC TYPE_DECL node. */
gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
if (TREE_CODE (gnu_decl) != TYPE_DECL)
with Einfo; use Einfo;
with Erroutc; use Erroutc;
with Fname; use Fname;
+with Hostparm; use Hostparm;
with Lib; use Lib;
with Namet; use Namet;
with Opt; use Opt;
-- 'Class appended to its name (see Add_Class procedure), and is
-- otherwise unchanged.
+ procedure VMS_Convert;
+ -- This procedure has no effect if called when the host is not OpenVMS.
+ -- If the host is indeed OpenVMS, then the error message stored in
+ -- Msg_Buffer is scanned for appearences of switch names which need
+ -- converting to corresponding VMS qualifer names. See Gnames/Vnames
+ -- table in Errout spec for precise definition of the conversion that
+ -- is performed by this routine in OpenVMS mode.
+
-----------------------
-- Change_Error_Text --
-----------------------
Set_Msg_Char (C);
end case;
end loop;
+
+ VMS_Convert;
end Set_Msg_Text;
----------------
end if;
end Unwind_Internal_Type;
+ -----------------
+ -- VMS_Convert --
+ -----------------
+
+ procedure VMS_Convert is
+ P : Natural;
+ L : Natural;
+ N : Natural;
+
+ begin
+ if not OpenVMS then
+ return;
+ end if;
+
+ P := Msg_Buffer'First;
+ loop
+ if P >= Msglen then
+ return;
+ end if;
+
+ if Msg_Buffer (P) = '-' then
+ for G in Gnames'Range loop
+ L := Gnames (G)'Length;
+
+ -- See if we have "-ggg switch", where ggg is Gnames entry
+
+ if P + L + 7 <= Msglen
+ and then Msg_Buffer (P + 1 .. P + L) = Gnames (G).all
+ and then Msg_Buffer (P + L + 1 .. P + L + 7) = " switch"
+ then
+ -- Replace by "/vvv qualifier", where vvv is Vnames entry
+
+ N := Vnames (G)'Length;
+ Msg_Buffer (P + N + 11 .. Msglen + N - L + 3) :=
+ Msg_Buffer (P + L + 8 .. Msglen);
+ Msg_Buffer (P) := '/';
+ Msg_Buffer (P + 1 .. P + N) := Vnames (G).all;
+ Msg_Buffer (P + N + 1 .. P + N + 10) := " qualifier";
+ P := P + N + 10;
+ Msglen := Msglen + N - L + 3;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ P := P + 1;
+ end loop;
+ end VMS_Convert;
+
end Errout;
-- --
-- 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- --
-- to be non-serious, and does not cause Serious_Errors_Detected
-- to be incremented (so expansion is not prevented by such a msg).
+ ----------------------------------------
+ -- Specialization of Messages for VMS --
+ ----------------------------------------
+
+ -- Some messages mention gcc-style switch names. When using an OpenVMS
+ -- host, such switch names must be converted to their corresponding VMS
+ -- qualifer. The following table controls this translation. In each case
+ -- the original message must contain the string "-xxx switch", where xxx
+ -- is the Gname? entry from below, and this string will be replaced by
+ -- "/yyy qualifier", where yyy is the corresponding Vname? entry.
+
+ Gname1 : aliased constant String := "fno-strict-aliasing";
+ Vname1 : aliased constant String := "OPTIMIZE=NO_ALIASING";
+
+ Gname2 : aliased constant String := "gnatX";
+ Vname2 : aliased constant String := "EXTENSIONS_ALLOWED";
+
+ Gname3 : aliased constant String := "gnatW";
+ Vname3 : aliased constant String := "WIDE_CHARACTER_ENCODING";
+
+ Gname4 : aliased constant String := "gnatf";
+ Vname4 : aliased constant String := "REPORT_ERRORS=FULL";
+
+ type Cstring_Ptr is access constant String;
+
+ Gnames : array (Nat range <>) of Cstring_Ptr :=
+ (Gname1'Access,
+ Gname2'Access,
+ Gname3'Access,
+ Gname4'Access);
+
+ Vnames : array (Nat range <>) of Cstring_Ptr :=
+ (Vname1'Access,
+ Vname2'Access,
+ Vname3'Access,
+ Vname4'Access);
+
-----------------------------------------------------
-- Global Values Used for Error Message Insertions --
-----------------------------------------------------
-- where rec is a selector whose Entry_Formal link points to the formal
-- For a formal of a task entity, the formal is rewritten as a local
-- renaming.
+
-- In addition, a formal that is marked volatile because it is aliased
-- through an address clause is rewritten as dereference as well.
----------------------
procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
+ Component_In_Lhs : Boolean := False;
+ Par : Node_Id;
+
begin
- Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
+ -- Loop to determine whether there is a component reference in
+ -- the left hand side if this appears on the left side of an
+ -- assignment statement. Needed to determine if form of result
+ -- must be a variable.
+
+ Par := Exp;
+ while Present (Par)
+ and then Nkind (Par) = N_Selected_Component
+ loop
+ if Nkind (Parent (Par)) = N_Assignment_Statement
+ and then Par = Name (Parent (Par))
+ then
+ Component_In_Lhs := True;
+ exit;
+ else
+ Par := Parent (Par);
+ end if;
+ end loop;
+
+ -- If the expression is a selected component, it is being evaluated
+ -- as part of a discriminant check. If it is part of a left-hand
+ -- side, this is the last use of its value and it is safe to create
+ -- a renaming for it, rather than a temporary. In addition, if it
+ -- is not an addressable field, creating a temporary may be a problem
+ -- for gigi, or might drop the value of the assignment. Therefore,
+ -- if the expression is on the lhs of an assignment, remove side
+ -- effects without requiring a temporary, and create a renaming.
+ -- (See remove_side_effects for details).
+
+ Remove_Side_Effects
+ (Exp, Name_Req, Variable_Ref => not Component_In_Lhs);
end Force_Evaluation;
------------------------
S := Scope (S);
end loop;
end;
+
+ -- Similarly, an inlined instance body may make reference to global
+ -- entities, but these references cannot be the proper freezing point
+ -- for them, and the the absence of inlining freezing will take place
+ -- in their own scope. Normally instance bodies are analyzed after
+ -- the enclosing compilation, and everything has been frozen at the
+ -- proper place, but with front-end inlining an instance body is
+ -- compiled before the end of the enclosing scope, and as a result
+ -- out-of-order freezing must be prevented.
+
+ elsif Front_End_Inlining
+ and then In_Instance_Body
+ and then Present (Scope (E))
+ then
+ declare
+ S : Entity_Id := Scope (E);
+ begin
+ while Present (S) loop
+ if Is_Generic_Instance (S) then
+ exit;
+ else
+ S := Scope (S);
+ end if;
+ end loop;
+
+ if No (S) then
+ return No_List;
+ end if;
+ end;
end if;
-- Here to freeze the entity
"copy file time stamp from file1 to file2");
Put_Line (Standard_Error, " prefix " &
"get the prefix of the GNAT installation");
- Put_Line (Standard_Error, " path " &
- "convert a directory list into a path list");
+ Put_Line (Standard_Error, " path_sep " &
+ "returns the path separator");
Put_Line (Standard_Error, " linkopts " &
"process attribute Linker'Linker_Options");
Put_Line (Standard_Error, " ignore " &
-- For "path" just add path separator after each directory argument
- elsif Cmd = "path" then
- for J in 2 .. Argument_Count loop
- Put (Argument (J));
- Put (Path_Separator);
- end loop;
+ elsif Cmd = "path_sep" then
+ Put (Path_Separator);
-- Check the linker options for relative paths. Insert the project
-- base dir before relative paths.
case 1381050: /* Nickerson bug #33 ??? */
return SS$_RESIGNAL;
+ case 20480426: /* RDB-E-STREAM_EOF */
+ return SS$_RESIGNAL;
+
case 11829410: /* Resignalled as Use_Error for CE10VRC */
return SS$_RESIGNAL;
-- --
-- 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- --
with Fname; use Fname;
with Fname.UF; use Fname.UF;
-with Hostparm; use Hostparm;
with Uname; use Uname;
separate (Par)
if not Extensions_Allowed then
Error_Msg_SP ("`LIMITED WITH` is an Ada0X extension");
-
- if OpenVMS then
- Error_Msg_SP
- ("\unit must be compiled with " &
- "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
- else
- Error_Msg_SP
- ("\unit must be compiled with -gnatX switch");
- end if;
+ Error_Msg_SP
+ ("\unit must be compiled with -gnatX switch");
end if;
else
Has_Limited := False;
if not Extensions_Allowed then
Error_Msg_SP ("`WITH TYPE` is a non-standard extension");
-
- if OpenVMS then
- Error_Msg_SP
- ("\unit must be compiled with " &
- "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
- else
- Error_Msg_SP
- ("\unit must be compiled with -gnatX switch");
- end if;
+ Error_Msg_SP ("\unit must be compiled with -gnatX switch");
end if;
Scan; -- past TYPE
-- Turn off subprogram body ordering check. Subprograms are in order
-- by RM section rather than alphabetical
-with Hostparm; use Hostparm;
with Sinfo.CN; use Sinfo.CN;
separate (Par)
Error_Msg_SP
("generalized use of anonymous access types " &
"is an Ada 0Y extension");
-
- if OpenVMS then
- Error_Msg_SP
- ("\unit must be compiled with " &
- "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
- else
- Error_Msg_SP
- ("\unit must be compiled with -gnatX switch");
- end if;
+ Error_Msg_SP ("\unit must be compiled with -gnatX switch");
end if;
Acc_Node := P_Access_Definition;
Error_Msg_SP
("generalized use of anonymous access types " &
"is an Ada 0Y extension");
-
- if OpenVMS then
- Error_Msg_SP
- ("\unit must be compiled with " &
- "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
- else
- Error_Msg_SP
- ("\unit must be compiled with -gnatX switch");
- end if;
+ Error_Msg_SP ("\unit must be compiled with -gnatX switch");
end if;
Set_Subtype_Indication (CompDef_Node, Empty);
Error_Msg_SP
("Generalized use of anonymous access types " &
"is an Ada0X extension");
-
- if OpenVMS then
- Error_Msg_SP
- ("\unit must be compiled with " &
- "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
- else
- Error_Msg_SP
- ("\unit must be compiled with -gnatX switch");
- end if;
+ Error_Msg_SP ("\unit must be compiled with -gnatX switch");
end if;
Set_Subtype_Indication (CompDef_Node, Empty);
-- --
-- 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- --
-- Turn off subprogram body ordering check. Subprograms are in order
-- by RM section rather than alphabetical
-with Hostparm; use Hostparm;
-
separate (Par)
package body Ch4 is
if not Extensions_Allowed then
Error_Msg_SP
("(Ada 0Y) limited aggregates are an Ada0X extension");
-
- if OpenVMS then
- Error_Msg_SP
- ("\unit must be compiled with " &
- "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
- else
- Error_Msg_SP
- ("\unit must be compiled with -gnatX switch");
- end if;
+ Error_Msg_SP ("\unit must be compiled with -gnatX switch");
end if;
Set_Box_Present (Assoc_Node);
-- --
-- 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- --
-- platforms, except on VMS where the logical names are deassigned, thus
-- avoiding the pollution of the environment of the caller.
- package Namings is new Table.Table (
- Table_Component_Type => Naming_Data,
- Table_Index_Type => Naming_Id,
- Table_Low_Bound => 1,
- Table_Initial => 5,
- Table_Increment => 100,
- Table_Name => "Prj.Env.Namings");
+ package Namings is new Table.Table
+ (Table_Component_Type => Naming_Data,
+ Table_Index_Type => Naming_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 5,
+ Table_Increment => 100,
+ Table_Name => "Prj.Env.Namings");
Default_Naming : constant Naming_Id := Namings.First;
Fill_Mapping_File : Boolean := True;
- package Path_Files is new Table.Table (
- Table_Component_Type => Name_Id,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 50,
- Table_Increment => 50,
- Table_Name => "Prj.Env.Path_Files");
+ package Path_Files is new Table.Table
+ (Table_Component_Type => Name_Id,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 50,
+ Table_Increment => 50,
+ Table_Name => "Prj.Env.Path_Files");
-- Table storing all the temp path file names.
-- Used by Delete_All_Path_Files.
begin
while Current /= Nil_String loop
Source_Dir := String_Elements.Table (Current);
- Add_To_Path (Get_Name_String (Source_Dir.Value));
+ Add_To_Path (Get_Name_String (Source_Dir.Display_Value));
Current := Source_Dir.Next;
end loop;
end Add_To_Path;
The_String : String_Element;
begin
- -- Call action with the name of every source directorie
-
- while Current /= Nil_String loop
- The_String := String_Elements.Table (Current);
- Action (Get_Name_String (The_String.Value));
- Current := The_String.Next;
- end loop;
+ -- If there are Ada sources, call action with the name of every
+ -- source directory.
+
+ if Projects.Table (Project).Sources_Present then
+ while Current /= Nil_String loop
+ The_String := String_Elements.Table (Current);
+ Action (Get_Name_String (The_String.Value));
+ Current := The_String.Next;
+ end loop;
+ end if;
end;
-- If we are extending a project, visit it
if Process_Source_Dirs then
-- Add to path all source directories of this project
+ -- if there are Ada sources.
- Add_To_Path_File (Data.Source_Dirs, Source_FD);
+ if Projects.Table (Project).Sources_Present then
+ Add_To_Path_File (Data.Source_Dirs, Source_FD);
+ end if;
end if;
if Process_Object_Dirs then
-- --
-- B o d y --
-- --
--- 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- --
-- If a non extending project is not supposed to contain
-- any source, then we never call Find_Sources.
- if Data.Extends = No_Project
- and then Current_Source = Nil_String
- then
+ 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",
String_Elements.Increment_Last;
String_Elements.Table (String_Elements.Last) :=
(Value => ALI_Name_Id,
- Display_Value => No_Name,
+ Display_Value => ALI_Name_Id,
Location => String_Elements.Table
(Interfaces).Location,
Flag => False,
Directory : constant String := Get_Name_String (From);
Element : String_Element;
- Canonical_Directory_Id : Name_Id;
- pragma Unreferenced (Canonical_Directory_Id);
- -- Is this in fact being used for anything useful ???
-
procedure Recursive_Find_Dirs (Path : Name_Id);
-- Find all the subdirectories (recursively) of Path and add them
-- to the list of source directories of the project.
Element : String_Element;
Found : Boolean := False;
- Canonical_Path : Name_Id := No_Name;
+ Non_Canonical_Path : Name_Id := No_Name;
+ Canonical_Path : Name_Id := No_Name;
+
+ The_Path : constant String :=
+ Normalize_Pathname (Get_Name_String (Path)) &
+ Directory_Separator;
+
+ The_Path_Last : constant Natural :=
+ Compute_Directory_Last (The_Path);
begin
- Get_Name_String (Path);
+ Name_Len := The_Path_Last - The_Path'First + 1;
+ Name_Buffer (1 .. Name_Len) :=
+ The_Path (The_Path'First .. The_Path_Last);
+ Non_Canonical_Path := Name_Find;
+ Get_Name_String (Non_Canonical_Path);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Canonical_Path := Name_Find;
- declare
- The_Path : constant String :=
- Normalize_Pathname
- (Name => Name_Buffer (1 .. Name_Len)) &
- Directory_Separator;
+ -- To avoid processing the same directory several times, check
+ -- if the directory is already in Recursive_Dirs. If it is,
+ -- then there is nothing to do, just return. If it is not, put
+ -- it there and continue recursive processing.
- The_Path_Last : constant Natural :=
- Compute_Directory_Last (The_Path);
+ if Recursive_Dirs.Get (Canonical_Path) then
+ return;
- begin
- Name_Len := The_Path_Last - The_Path'First + 1;
- Name_Buffer (1 .. Name_Len) :=
- The_Path (The_Path'First .. The_Path_Last);
- Canonical_Path := Name_Find;
+ else
+ Recursive_Dirs.Set (Canonical_Path, True);
+ end if;
- -- To avoid processing the same directory several times, check
- -- if the directory is already in Recursive_Dirs. If it is,
- -- then there is nothing to do, just return. If it is not, put
- -- it there and continue recursive processing.
+ -- Check if directory is already in list
- if Recursive_Dirs.Get (Canonical_Path) then
- return;
+ while List /= Nil_String loop
+ Element := String_Elements.Table (List);
- else
- Recursive_Dirs.Set (Canonical_Path, True);
+ if Element.Value /= No_Name then
+ Found := Element.Value = Canonical_Path;
+ exit when Found;
end if;
- -- Check if directory is already in list
-
- while List /= Nil_String loop
- Element := String_Elements.Table (List);
-
- if Element.Value /= No_Name then
- Get_Name_String (Element.Value);
- Found :=
- The_Path (The_Path'First .. The_Path_Last) =
- Name_Buffer (1 .. Name_Len);
- exit when Found;
- end if;
-
- List := Element.Next;
- end loop;
-
- -- If directory is not already in list, put it there
-
- if not Found then
- if Current_Verbosity = High then
- Write_Str (" ");
- Write_Line (The_Path (The_Path'First .. The_Path_Last));
- end if;
+ List := Element.Next;
+ end loop;
- String_Elements.Increment_Last;
- Element :=
- (Value => Canonical_Path,
- Display_Value => No_Name,
- Location => No_Location,
- Flag => False,
- Next => Nil_String);
+ -- If directory is not already in list, put it there
- -- Case of first source directory
+ if not Found then
+ if Current_Verbosity = High then
+ Write_Str (" ");
+ Write_Line (The_Path (The_Path'First .. The_Path_Last));
+ end if;
- if Last_Source_Dir = Nil_String then
- Data.Source_Dirs := String_Elements.Last;
+ String_Elements.Increment_Last;
+ Element :=
+ (Value => Canonical_Path,
+ Display_Value => Non_Canonical_Path,
+ Location => No_Location,
+ Flag => False,
+ Next => Nil_String);
- -- Here we already have source directories.
+ -- Case of first source directory
- else
- -- Link the previous last to the new one
+ if Last_Source_Dir = Nil_String then
+ Data.Source_Dirs := String_Elements.Last;
- String_Elements.Table (Last_Source_Dir).Next :=
- String_Elements.Last;
- end if;
+ -- Here we already have source directories.
- -- And register this source directory as the new last
+ else
+ -- Link the previous last to the new one
- Last_Source_Dir := String_Elements.Last;
- String_Elements.Table (Last_Source_Dir) := Element;
+ String_Elements.Table (Last_Source_Dir).Next :=
+ String_Elements.Last;
end if;
- -- Now look for subdirectories. We do that even when this
- -- directory is already in the list, because some of its
- -- subdirectories may not be in the list yet.
+ -- And register this source directory as the new last
- Open (Dir, The_Path (The_Path'First .. The_Path_Last));
+ Last_Source_Dir := String_Elements.Last;
+ String_Elements.Table (Last_Source_Dir) := Element;
+ end if;
- loop
- Read (Dir, Name, Last);
- exit when Last = 0;
+ -- Now look for subdirectories. We do that even when this
+ -- directory is already in the list, because some of its
+ -- subdirectories may not be in the list yet.
- if Name (1 .. Last) /= "."
- and then Name (1 .. Last) /= ".."
- then
- -- Avoid . and ..
+ Open (Dir, The_Path (The_Path'First .. The_Path_Last));
- if Current_Verbosity = High then
- Write_Str (" Checking ");
- Write_Line (Name (1 .. Last));
- end if;
+ loop
+ Read (Dir, Name, Last);
+ exit when Last = 0;
- declare
- Path_Name : String :=
- Normalize_Pathname
- (Name => Name (1 .. Last),
- Directory =>
- The_Path
- (The_Path'First .. The_Path_Last));
+ if Name (1 .. Last) /= "."
+ and then Name (1 .. Last) /= ".."
+ then
+ -- Avoid . and ..
- begin
- Canonical_Case_File_Name (Path_Name);
+ if Current_Verbosity = High then
+ Write_Str (" Checking ");
+ Write_Line (Name (1 .. Last));
+ end if;
- if Is_Directory (Path_Name) then
+ declare
+ Path_Name : constant String :=
+ Normalize_Pathname
+ (Name => Name (1 .. Last),
+ Directory =>
+ The_Path
+ (The_Path'First .. The_Path_Last));
- -- We have found a new subdirectory, call self
+ begin
+ if Is_Directory (Path_Name) then
- Name_Len := Path_Name'Length;
- Name_Buffer (1 .. Name_Len) := Path_Name;
- Recursive_Find_Dirs (Name_Find);
- end if;
- end;
- end if;
- end loop;
+ -- We have found a new subdirectory, call self
- Close (Dir);
- end;
+ Name_Len := Path_Name'Length;
+ Name_Buffer (1 .. Name_Len) := Path_Name;
+ Recursive_Find_Dirs (Name_Find);
+ end if;
+ end;
+ end if;
+ end loop;
+
+ Close (Dir);
exception
when Directory_Error =>
-- Directory := Name_Buffer (1 .. Name_Len);
-- Why is above line commented out ???
- Canonical_Directory_Id := Name_Find;
- -- What is purpose of above assignment ???
- -- Are we sure it is being used ???
-
if Current_Verbosity = High then
Write_Str (Directory);
Write_Line (""")");
while Current /= Nil_String loop
Element := String_Elements.Table (Current);
if Element.Value /= No_Name then
- Element.Display_Value := Element.Value;
Get_Name_String (Element.Value);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
Element.Value := Name_Find;
begin
Name_Len := Normed'Length;
Name_Buffer (1 .. Name_Len) := Normed;
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
Canonical_Path_Name := Name_Find;
for Index in 1 .. Project_Stack.Last loop
for Current in reverse 1 .. Project_Stack.Last loop
Error_Msg_Name_1 := Project_Stack.Table (Current).Path_Name;
- if Error_Msg_Name_1 /= Canonical_Path_Name then
+ if Project_Stack.Table (Current).Canonical_Path_Name /=
+ Canonical_Path_Name
+ then
Error_Msg
("\ { which itself is imported by", Token_Ptr);
--
-- This must be called with abortion deferred and with the corresponding
-- object locked.
- -- If Unlock_Object, then Object is unlocked on return.
+ --
+ -- If Unlock_Object is set True, then Object is unlocked on return,
+ -- otherwise Object remains locked and the caller is responsible for
+ -- the required unlock.
procedure Complete_Entry_Body (Object : Entries.Protection_Entries_Access);
-- Called from within an entry body procedure, indicates that the
-- Finish initialization
+ Lock_RTS;
System.Tasking.Initialize_ATCB
(Self_Id, null, Null_Address, Null_Task,
Foreign_Task_Elaborated'Access,
System.Priority'First, Task_Info.Unspecified_Task_Info, 0, Self_Id,
Succeeded);
+ Unlock_RTS;
pragma Assert (Succeeded);
Self_Id.Master_of_Task := 0;
-- --
-- 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- --
procedure Error_Illegal_Wide_Character is
begin
- if OpenVMS then
- Error_Msg_S
- ("illegal wide character, check " &
- "'/'W'I'D'E'_'C'H'A'R'A'C'T'E'R'_'E'N'C'O'D'I'N'G qualifier");
- else
- Error_Msg_S
- ("illegal wide character, check -gnatW switch");
- end if;
-
+ Error_Msg_S ("illegal wide character, check -gnatW switch");
Scan_Ptr := Scan_Ptr + 1;
end Error_Illegal_Wide_Character;
-- --
-- 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- --
is
E : Entity_Id;
+ Enode : Node_Id;
+ -- This is where we post error messages for bounds out of range
+
Nb_Choices : constant Nat := Choice_Table'Length;
Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices);
end if;
end if;
- -- Check for bound out of range.
+ -- Check for low bound out of range
if Lo_Val < Bounds_Lo then
+
+ -- If the choice is an entity name, then it is a type, and
+ -- we want to post the message on the reference to this
+ -- entity. Otherwise we want to post it on the lower bound
+ -- of the range.
+
+ if Is_Entity_Name (Choice) then
+ Enode := Choice;
+ else
+ Enode := Lo;
+ end if;
+
+ -- Specialize message for integer/enum type
+
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Bounds_Lo;
- Error_Msg_N ("minimum allowed choice value is^", Lo);
+ Error_Msg_N ("minimum allowed choice value is^", Enode);
else
Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type);
- Error_Msg_N ("minimum allowed choice value is%", Lo);
+ Error_Msg_N ("minimum allowed choice value is%", Enode);
end if;
+ end if;
+
+ -- Check for high bound out of range
+
+ if Hi_Val > Bounds_Hi then
+
+ -- If the choice is an entity name, then it is a type, and
+ -- we want to post the message on the reference to this
+ -- entity. Otherwise we want to post it on the upper bound
+ -- of the range.
+
+ if Is_Entity_Name (Choice) then
+ Enode := Choice;
+ else
+ Enode := Hi;
+ end if;
+
+ -- Specialize message for integer/enum type
- elsif Hi_Val > Bounds_Hi then
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Bounds_Hi;
- Error_Msg_N ("maximum allowed choice value is^", Hi);
+ Error_Msg_N ("maximum allowed choice value is^", Enode);
else
Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type);
- Error_Msg_N ("maximum allowed choice value is%", Hi);
+ Error_Msg_N ("maximum allowed choice value is%", Enode);
end if;
end if;
then
Comp_Unit := Cunit (Unum);
- Set_Corresponding_Stub (Unit (Comp_Unit), N);
- Analyze_Subunit (Comp_Unit);
- Set_Library_Unit (N, Comp_Unit);
+ if Nkind (Unit (Comp_Unit)) /= N_Subunit then
+ Error_Msg_N
+ ("expected SEPARATE subunit, found child unit",
+ Cunit_Entity (Unum));
+ else
+ Set_Corresponding_Stub (Unit (Comp_Unit), N);
+ Analyze_Subunit (Comp_Unit);
+ Set_Library_Unit (N, Comp_Unit);
+ end if;
elsif Unum = No_Unit
and then Present (Nam)
with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Util; use Exp_Util;
-with Hostparm; use Hostparm;
with Itypes; use Itypes;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
List_Operand_Interps (Left_Opnd (N));
List_Operand_Interps (Right_Opnd (N));
else
-
- if OpenVMS then
- Error_Msg_N (
- "\use '/'R'E'P'O'R'T'_'E'R'R'O'R'S'='F'U'L'L for details",
- N);
- else
- Error_Msg_N ("\use -gnatf for details", N);
- end if;
+ Error_Msg_N ("\use -gnatf switch for details", N);
end if;
end Ambiguous_Operands;
-- Then we need to see if the static scope matches within the
-- compilation unit.
+
-- At the moment, gnatelim does not consider block statements as
-- scopes (even if a block is named)
Scop := Scope (E);
-
while Ekind (Scop) = E_Block loop
Scop := Scope (Scop);
end loop;
end if;
Scop := Scope (Scop);
-
while Ekind (Scop) = E_Block loop
Scop := Scope (Scop);
end loop;
end if;
Scop := Scope (Scop);
-
while Ekind (Scop) = E_Block loop
Scop := Scope (Scop);
end loop;
begin
pragma Assert (False
or else NT (N).Nkind = N_With_Clause);
- return Flag15 (N);
+ return Flag14 (N);
end Elaborate_All_Present;
function Elaborate_Present
begin
pragma Assert (False
or else NT (N).Nkind = N_Compilation_Unit
- or else NT (N).Nkind = N_Formal_Derived_Type_Definition);
+ or else NT (N).Nkind = N_Formal_Derived_Type_Definition
+ or else NT (N).Nkind = N_With_Clause);
return Flag15 (N);
end Private_Present;
begin
pragma Assert (False
or else NT (N).Nkind = N_With_Clause);
- Set_Flag15 (N, Val);
+ Set_Flag14 (N, Val);
end Set_Elaborate_All_Present;
procedure Set_Elaborate_Present
begin
pragma Assert (False
or else NT (N).Nkind = N_Compilation_Unit
- or else NT (N).Nkind = N_Formal_Derived_Type_Definition);
+ or else NT (N).Nkind = N_Formal_Derived_Type_Definition
+ or else NT (N).Nkind = N_With_Clause);
Set_Flag15 (N, Val);
end Set_Private_Present;
-- This flag is set in the N_With_Clause node to indicate that a
-- pragma Elaborate pragma appears for the with'ed units.
- -- Elaborate_All_Present (Flag15-Sem)
+ -- Elaborate_All_Present (Flag14-Sem)
-- This flag is set in the N_With_Clause node to indicate that a
-- pragma Elaborate_All pragma appears for the with'ed units.
-- generic templates, this is harmless.
-- Entity_Or_Associated_Node (Node4-Sem)
- -- A synonym for both Entity and Asasociated_Node. Used by convention
+ -- A synonym for both Entity and Associated_Node. Used by convention
-- in the code when referencing this field in cases where it is not
-- known whether the field contains an Entity or an Associated_Node.
-- Last_Name (Flag6) (set to True if last name or only one name)
-- Context_Installed (Flag13-Sem)
-- Elaborate_Present (Flag4-Sem)
- -- Elaborate_All_Present (Flag15-Sem)
+ -- Elaborate_All_Present (Flag14-Sem)
+ -- Private_Present (Flag15) set if with_clause has private keyword
-- Implicit_With (Flag16-Sem)
-- Limited_Present (Flag17) set if LIMITED is present
-- Limited_View_Installed (Flag18-Sem)
-- Note: Limited_Present and Limited_View_Installed give support to
-- Ada 0Y (AI-50217).
+ -- Similarly, Private_Present gives support to AI-50262.
----------------------
-- With_Type clause --
(N : Node_Id) return Boolean; -- Flag13
function Elaborate_All_Present
- (N : Node_Id) return Boolean; -- Flag15
+ (N : Node_Id) return Boolean; -- Flag14
function Elaborate_Present
(N : Node_Id) return Boolean; -- Flag4
(N : Node_Id; Val : Boolean := True); -- Flag13
procedure Set_Elaborate_All_Present
- (N : Node_Id; Val : Boolean := True); -- Flag15
+ (N : Node_Id; Val : Boolean := True); -- Flag14
procedure Set_Elaborate_Present
(N : Node_Id; Val : Boolean := True); -- Flag4
DECL_BIT_FIELD (field) = 0;
/* If we still have DECL_BIT_FIELD set at this point, we know the field
- is technically not addressable. */
- DECL_NONADDRESSABLE_P (field) |= DECL_BIT_FIELD (field);
+ is technically not addressable. Except that it can actually be
+ addressed if the field is BLKmode and happens to be properly
+ aligned. */
+ DECL_NONADDRESSABLE_P (field)
+ |= DECL_BIT_FIELD (field) && DECL_MODE (field) != BLKmode;
if (has_rep && ! DECL_BIT_FIELD (field))
TYPE_ALIGN (record_type)
projects / platform / upstream / linaro-gcc.git / commitdiff