+2004-06-28 Robert Dewar <dewar@gnat.com>
+
+ * mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb,
+ mlib-tgt-irix.adb, mlib-tgt-hpux.adb, mlib-tgt-linux.adb,
+ mlib-tgt-linux.adb, mlib-tgt-solaris.adb, mlib-tgt-solaris.adb,
+ mlib-tgt-vms-alpha.adb, mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb,
+ a-strmap.adb, a-strmap.ads, clean.adb: Minor reformatting
+
+ * exp_util.adb (Is_Possibly_Unaligned_Slice): Completely rewritten, to
+ deal with problem of inefficient slices on machines with strict
+ alignment, when the slice is a component of a composite.
+
+ * checks.adb (Apply_Array_Size_Check): Do not special case 64-bit
+ machines, we need the check there as well.
+
+2004-06-28 Ed Schonberg <schonberg@gnat.com>
+
+ * exp_ch5.adb (Expand_Assign_Array): Use correct condition to
+ determine safe copying direction for overlapping slice assignments
+ when component is controlled.
+
+ * sem_ch12.adb (Instantiate_Formal_Package): Implicit operations of a
+ formal derived type in the actual for a formal package are visible in
+ the enclosing instance.
+
+2004-06-28 Ed Schonberg <schonberg@gnat.com>
+
+ PR ada/15600
+ * sem_util.adb (Trace_Components): Diagnose properly an illegal
+ circularity involving a private type whose completion includes a
+ self-referential component.
+ (Enter_Name): Use Is_Inherited_Operation to distinguish a source
+ renaming or an instantiation from an implicit derived operation.
+
+2004-06-28 Pascal Obry <obry@gnat.com>
+
+ * mlib-tgt-mingw.adb: (Library_Exists_For): Remove "lib" prefix from
+ DLL.
+ (Library_File_Name_For): Idem.
+
+2004-06-28 Matthew Gingell <gingell@gnat.com>
+
+ * g-traceb.ads: Add explanatory note on the format of addresses
+ expected by addr2line.
+
+2004-06-28 Jerome Guitton <guitton@act-europe.fr>
+
+ * Makefile.in: Force debugging information on s-tasdeb.adb,
+ a-except.adb and s-assert.adb needed by the debugger.
+
+2004-06-28 Vincent Celier <celier@gnat.com>
+
+ * make.adb (Collect_Arguments_And_Compile): Change Flag1 to
+ Need_To_Build_Lib.
+ (Gnatmake): Ditto.
+
+ * mlib-prj.adb (Check_Library): Replace Flag1 with Need_To_Build_Lib
+
+ * prj.adb: Minor reformatting
+ (Project_Empty): Change Flag1 to Need_To_Build_Lib. Remove Flag2.
+
+ * prj.ads: Comment updates
+ Minor reformatting
+ (Project_Data): Change Flag1 to Need_To_Build_Lib.
+ Remove Flag2: not used.
+
+ * prj-dect.adb (Parse_Declarative_Items): Accept "null" as a
+ declaration.
+
+ * gnat_ugn.texi: Put a "null;" declaration in one project file example
+
+ * gnat_rm.texi: Document Empty declarations "null;".
+
+ * makegpr.adb (Compile_Link_With_Gnatmake): Put the global archives in
+ front of the linker options.
+ (Link_Foreign): Put the global archives and the libraries in front of
+ the linker options.
+
+2004-06-28 Javier Miranda <miranda@gnat.com>
+
+ * rtsfind.adb: (Get_Unit_Name): Fix typo in comment
+ (RTU_Loaded): Code cleanup
+ (Set_RTU_Loaded): New procedure to register as *loaded* explicitly
+ withed predefined units.
+
+ * rtsfind.ads (Set_RTU_Loaded): New procedure to register as *loaded*
+ explicitly withed predefined units.
+ Fix typo in comment
+
+ * sem_ch10.adb (Analyze_Compilation_Unit): Register as *loaded*
+ explicitly withed predefined units.
+
2004-06-25 Pascal Obry <obry@gnat.com>
* makegpr.adb (Build_Library): Remove parameter Lib_Address and
s-traceb.o : s-traceb.adb
$(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) \
$(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) \
+ $< $(OUTPUT_OPTION)
+
+# force debugging information on s-tasdeb.o so that it is always
+# possible to set conditional breakpoints on tasks.
+
+s-tasdeb.o : s-tasdeb.adb s-tasdeb.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \
+ $< $(OUTPUT_OPTION)
+
+# force debugging information on a-except.o so that it is always
+# possible to set conditional breakpoints on exceptions.
+# use -O1 otherwise gdb isn't able to get a full backtrace on mips targets.
+
+a-except.o : a-except.adb a-except.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \
+ $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
+
+# force debugging information on s-assert.o so that it is always
+# possible to set breakpoint on assert failures.
+
+s-assert.o : s-assert.adb s-assert.ads a-except.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 $(ADA_INCLUDES) \
$< $(OUTPUT_OPTION)
adadecode.o : adadecode.c adadecode.h
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 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, Right : in Character_Set) return Boolean is
+ function "=" (Left, Right : Character_Set) return Boolean is
begin
return Character_Set_Internal (Left) = Character_Set_Internal (Right);
end "=";
-- "and" --
-----------
- function "and" (Left, Right : in Character_Set) return Character_Set is
+ function "and" (Left, Right : Character_Set) return Character_Set is
begin
return Character_Set
(Character_Set_Internal (Left) and Character_Set_Internal (Right));
-- "not" --
-----------
- function "not" (Right : in Character_Set) return Character_Set is
+ function "not" (Right : Character_Set) return Character_Set is
begin
return Character_Set (not Character_Set_Internal (Right));
end "not";
-- "or" --
----------
- function "or" (Left, Right : in Character_Set) return Character_Set is
+ function "or" (Left, Right : Character_Set) return Character_Set is
begin
return Character_Set
(Character_Set_Internal (Left) or Character_Set_Internal (Right));
-- "xor" --
-----------
- function "xor" (Left, Right : in Character_Set) return Character_Set is
+ function "xor" (Left, Right : Character_Set) return Character_Set is
begin
return Character_Set
(Character_Set_Internal (Left) xor Character_Set_Internal (Right));
function Is_In
(Element : Character;
- Set : Character_Set)
- return Boolean
+ Set : Character_Set) return Boolean
is
begin
return Set (Element);
function Is_Subset
(Elements : Character_Set;
- Set : Character_Set)
- return Boolean
+ Set : Character_Set) return Boolean
is
begin
return (Elements and Set) = Elements;
-- To_Domain --
---------------
- function To_Domain (Map : in Character_Mapping) return Character_Sequence
+ function To_Domain (Map : Character_Mapping) return Character_Sequence
is
Result : String (1 .. Map'Length);
J : Natural;
----------------
function To_Mapping
- (From, To : in Character_Sequence)
- return Character_Mapping
+ (From, To : Character_Sequence) return Character_Mapping
is
Result : Character_Mapping;
Inserted : Character_Set := Null_Set;
-- To_Range --
--------------
- function To_Range (Map : in Character_Mapping) return Character_Sequence
+ function To_Range (Map : Character_Mapping) return Character_Sequence
is
Result : String (1 .. Map'Length);
J : Natural;
-
begin
J := 0;
for C in Map'Range loop
-- To_Ranges --
---------------
- function To_Ranges (Set : in Character_Set) return Character_Ranges is
+ function To_Ranges (Set : Character_Set) return Character_Ranges is
Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1);
Range_Num : Natural;
C : Character;
Range_Num := 0;
loop
- -- Skip gap between subsets.
+ -- Skip gap between subsets
while not Set (C) loop
exit when C = Character'Last;
Range_Num := Range_Num + 1;
Max_Ranges (Range_Num).Low := C;
- -- Span a subset.
+ -- Span a subset
loop
exit when not Set (C) or else C = Character'Last;
-- To_Sequence --
-----------------
- function To_Sequence
- (Set : Character_Set)
- return Character_Sequence
- is
+ function To_Sequence (Set : Character_Set) return Character_Sequence is
Result : String (1 .. Character'Pos (Character'Last) + 1);
Count : Natural := 0;
-
begin
for Char in Set'Range loop
if Set (Char) then
-- To_Set --
------------
- function To_Set (Ranges : in Character_Ranges) return Character_Set is
+ function To_Set (Ranges : Character_Ranges) return Character_Set is
Result : Character_Set;
-
begin
for C in Result'Range loop
Result (C) := False;
return Result;
end To_Set;
- function To_Set (Span : in Character_Range) return Character_Set is
+ function To_Set (Span : Character_Range) return Character_Set is
Result : Character_Set;
-
begin
for C in Result'Range loop
Result (C) := False;
function To_Set (Sequence : Character_Sequence) return Character_Set is
Result : Character_Set := Null_Set;
-
begin
for J in Sequence'Range loop
Result (Sequence (J)) := True;
function To_Set (Singleton : Character) return Character_Set is
Result : Character_Set := Null_Set;
-
begin
Result (Singleton) := True;
return Result;
-- Value --
-----------
- function Value (Map : in Character_Mapping; Element : in Character)
- return Character is
-
+ function Value
+ (Map : Character_Mapping;
+ Element : Character) return Character
+ is
begin
return Map (Element);
end Value;
type Character_Ranges is array (Positive range <>) of Character_Range;
- function To_Set (Ranges : in Character_Ranges) return Character_Set;
+ function To_Set (Ranges : Character_Ranges) return Character_Set;
- function To_Set (Span : in Character_Range) return Character_Set;
+ function To_Set (Span : Character_Range) return Character_Set;
- function To_Ranges (Set : in Character_Set) return Character_Ranges;
+ function To_Ranges (Set : Character_Set) return Character_Ranges;
----------------------------------
-- Operations on Character Sets --
----------------------------------
- function "=" (Left, Right : in Character_Set) return Boolean;
+ function "=" (Left, Right : Character_Set) return Boolean;
- function "not" (Right : in Character_Set) return Character_Set;
- function "and" (Left, Right : in Character_Set) return Character_Set;
- function "or" (Left, Right : in Character_Set) return Character_Set;
- function "xor" (Left, Right : in Character_Set) return Character_Set;
- function "-" (Left, Right : in Character_Set) return Character_Set;
+ function "not" (Right : Character_Set) return Character_Set;
+ function "and" (Left, Right : Character_Set) return Character_Set;
+ function "or" (Left, Right : Character_Set) return Character_Set;
+ function "xor" (Left, Right : Character_Set) return Character_Set;
+ function "-" (Left, Right : Character_Set) return Character_Set;
function Is_In
- (Element : in Character;
- Set : in Character_Set)
- return Boolean;
+ (Element : Character;
+ Set : Character_Set) return Boolean;
function Is_Subset
- (Elements : in Character_Set;
- Set : in Character_Set)
- return Boolean;
+ (Elements : Character_Set;
+ Set : Character_Set) return Boolean;
function "<="
- (Left : in Character_Set;
- Right : in Character_Set)
- return Boolean
+ (Left : Character_Set;
+ Right : Character_Set) return Boolean
renames Is_Subset;
subtype Character_Sequence is String;
-- Alternative representation for a set of character values
- function To_Set (Sequence : in Character_Sequence) return Character_Set;
+ function To_Set (Sequence : Character_Sequence) return Character_Set;
+ function To_Set (Singleton : Character) return Character_Set;
- function To_Set (Singleton : in Character) return Character_Set;
-
- function To_Sequence (Set : in Character_Set) return Character_Sequence;
+ function To_Sequence (Set : Character_Set) return Character_Sequence;
------------------------------------
-- Character Mapping Declarations --
-- Representation for a character to character mapping:
function Value
- (Map : in Character_Mapping;
- Element : in Character)
- return Character;
+ (Map : Character_Mapping;
+ Element : Character) return Character;
Identity : constant Character_Mapping;
----------------------------
function To_Mapping
- (From, To : in Character_Sequence)
- return Character_Mapping;
+ (From, To : Character_Sequence) return Character_Mapping;
function To_Domain
- (Map : in Character_Mapping)
- return Character_Sequence;
+ (Map : Character_Mapping) return Character_Sequence;
function To_Range
- (Map : in Character_Mapping)
- return Character_Sequence;
+ (Map : Character_Mapping) return Character_Sequence;
type Character_Mapping_Function is
- access function (From : in Character) return Character;
+ access function (From : Character) return Character;
private
pragma Inline (Is_In);
if Size_Known_At_Compile_Time (Typ) then
return;
end if;
-
- -- No problem on 64-bit machines, we just don't bother with
- -- the case where the size in bytes overflows 64-bits.
-
- if System_Address_Size = 64 then
- return;
- end if;
end if;
-- Following code is temporarily deleted, since GCC 3 is returning
procedure Clean_Archive (Project : Project_Id) is
Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
-
Data : constant Project_Data := Projects.Table (Project);
Archive_Name : constant String :=
- "lib" & Get_Name_String (Data.Name) & '.' & Archive_Ext;
+ "lib" & Get_Name_String (Data.Name) & '.' & Archive_Ext;
-- The name of the archive file for this project
Archive_Dep_Name : constant String :=
- "lib" & Get_Name_String (Data.Name) & ".deps";
+ "lib" & Get_Name_String (Data.Name) & ".deps";
-- The name of the archive dependency file for this project
Obj_Dir : constant String := Get_Name_String (Data.Object_Directory);
Extract_From_Q (Lib_File);
Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File);
- -- If we have an existing ALI file that is not read-only,
- -- process it.
+ -- If we have existing ALI file that is not read-only, process it
if Full_Lib_File /= No_File
and then not Is_Readonly_Library (Full_Lib_File)
end if;
end if;
- -- Now, delete all the existing files corresponding to this
- -- ALI file.
+ -- Now delete all existing files corresponding to this ALI file
declare
Obj_Dir : constant String :=
for J in 1 .. Sources.Last loop
declare
Deb : constant String :=
- Debug_File_Name (Sources.Table (J));
+ Debug_File_Name (Sources.Table (J));
Rep : constant String :=
- Repinfo_File_Name (Sources.Table (J));
+ Repinfo_File_Name (Sources.Table (J));
+
begin
if Is_Regular_File (Obj_Dir & Dir_Separator & Deb) then
Delete (Obj_Dir, Deb);
procedure Clean_Project (Project : Project_Id) is
Main_Source_File : File_Name_Type;
- -- Name of the executable on the command line, without directory
- -- information.
+ -- Name of executable on the command line without directory info
Executable : Name_Id;
-- Name of the executable file
begin
Change_Dir (Obj_Dir);
- -- First, deal with Ada.
+ -- First, deal with Ada
+
-- Look through the units to find those that are either immediate
-- sources or inherited sources of the project.
end if;
if Data.Other_Sources_Present then
+
-- There is non-Ada code: delete the object files and
- -- the dependency files, if they exist.
+ -- the dependency files if they exist.
Source_Id := Data.First_Other_Source;
Prj.Pars.Set_Verbosity (To => Prj.Com.Current_Verbosity);
- -- Parse the project file.
- -- If there is an error, Main_Project will still be No_Project.
+ -- Parse the project file. If there is an error, Main_Project
+ -- will still be No_Project.
Prj.Pars.Parse
(Project => Main_Project,
Process_Languages => All_Languages);
if Main_Project = No_Project then
- Fail ("""" & Project_File_Name.all &
- """ processing failed");
+ Fail ("""" & Project_File_Name.all & """ processing failed");
end if;
if Opt.Verbose_Mode then
procedure Parse_Cmd_Line is
Source_Index : Int := 0;
Index : Positive := 1;
- Last : constant Natural := Argument_Count;
+ Last : constant Natural := Argument_Count;
+
begin
while Index <= Last loop
declare
-- the explicit bounds of right- and left-hand side.
declare
- Proc : constant Node_Id :=
- TSS (Base_Type (L_Type), TSS_Slice_Assign);
+ Proc : constant Node_Id :=
+ TSS (Base_Type (L_Type), TSS_Slice_Assign);
Actuals : List_Id;
begin
Duplicate_Subexpr (Left_Hi, Name_Req => True),
Duplicate_Subexpr (Right_Lo, Name_Req => True),
Duplicate_Subexpr (Right_Hi, Name_Req => True));
- Append_To (Actuals, Condition);
+
+ Append_To (Actuals,
+ Make_Op_Not (Loc,
+ Right_Opnd => Condition));
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
---------------------------------
function Is_Possibly_Unaligned_Slice (P : Node_Id) return Boolean is
-
- function Has_Non_Trivial_Component_Clause (E : Entity_Id) return Boolean;
- -- Check whether the component clause might place the component at an
- -- alignment that will require the use of a copy when a slice is passed
- -- as a parameter. The code is conservative because at this point the
- -- expander does not know the alignment choice that the back-end will
- -- make. For now we return true if the component is not the first one
- -- in the enclosing record. This routine is a place holder for further
- -- analysis of this kind.
-
- --------------------------------------
- -- Has_Non_Trivial_Component_Clause --
- --------------------------------------
-
- function Has_Non_Trivial_Component_Clause (E : Entity_Id) return Boolean
- is
- Rep_Clause : constant Node_Id := Component_Clause (E);
- begin
- if No (Rep_Clause) then
- return False;
- else
- return Intval (Position (Rep_Clause)) /= Uint_0
- or else Intval (First_Bit (Rep_Clause)) /= Uint_0;
- end if;
- end Has_Non_Trivial_Component_Clause;
-
- -- Start of processing for Is_Possibly_Unaligned_Slice
-
begin
-- ??? GCC3 will eventually handle strings with arbitrary alignments,
-- but for now the following check must be disabled.
-- return False;
-- end if;
+ -- For renaming case, go to renamed object
+
if Is_Entity_Name (P)
and then Is_Object (Entity (P))
and then Present (Renamed_Object (Entity (P)))
return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (P)));
end if;
- -- We only need to worry if the target has strict alignment, unless
- -- it is a nested record component with a component clause, which
- -- Gigi does not handle well. This patch should disappear with GCC 3.0
- -- and it is not clear why it is needed even when the representation
- -- clause is a confirming one, but in its absence gigi complains that
- -- the slice is not addressable.???
+ -- The reference must be a slice
- if not Target_Strict_Alignment then
- if Nkind (P) /= N_Slice
- or else Nkind (Prefix (P)) /= N_Selected_Component
- or else Nkind (Prefix (Prefix (P))) /= N_Selected_Component
- then
- return False;
- end if;
+ if Nkind (P) /= N_Slice then
+ return False;
end if;
- -- The reference must be a slice
+ -- Always assume the worst for a nested record component with a
+ -- component clause, which gigi/gcc does not appear to handle well.
+ -- It is not clear why this special test is needed at all ???
- if Nkind (P) /= N_Slice then
+ if Nkind (Prefix (P)) = N_Selected_Component
+ and then Nkind (Prefix (Prefix (P))) = N_Selected_Component
+ and then
+ Present (Component_Clause (Entity (Selector_Name (Prefix (P)))))
+ then
+ return True;
+ end if;
+
+ -- We only need to worry if the target has strict alignment
+
+ if not Target_Strict_Alignment then
return False;
end if;
-- If it is a slice, then look at the array type being sliced
declare
- Pref : constant Node_Id := Prefix (P);
- Typ : constant Entity_Id := Etype (Prefix (P));
+ Sarr : constant Node_Id := Prefix (P);
+ -- Prefix of the slice, i.e. the array being sliced
+
+ Styp : constant Entity_Id := Etype (Prefix (P));
+ -- Type of the array being sliced
+
+ Pref : Node_Id;
+ Ptyp : Entity_Id;
begin
- -- The worrisome case is one where we don't know the alignment
- -- of the array, or we know it and it is greater than 1 (if the
- -- alignment is one, then obviously it cannot be misaligned).
+ -- The problems arise if the array object that is being sliced
+ -- is a component of a record or array, and we cannot guarantee
+ -- the alignment of the array within its containing object.
- if Known_Alignment (Typ) and then Alignment (Typ) = 1 then
- return False;
- end if;
+ -- To investigate this, we look at successive prefixes to see
+ -- if we have a worrisome indexed or selected component.
- -- The only way we can be unaligned is if the array being sliced
- -- is a component of a record, and either the record is packed,
- -- or the component has a component clause, or the record has
- -- a specified alignment (that might be too small).
+ Pref := Sarr;
+ loop
+ -- Case of array is part of an indexed component reference
- return
- Nkind (Pref) = N_Selected_Component
- and then
- (Is_Packed (Etype (Prefix (Pref)))
- or else
- Known_Alignment (Etype (Prefix (Pref)))
- or else
- Has_Non_Trivial_Component_Clause
- (Entity (Selector_Name (Pref))));
+ if Nkind (Pref) = N_Indexed_Component then
+ Ptyp := Etype (Prefix (Pref));
+
+ -- The only problematic case is when the array is packed,
+ -- in which case we really know nothing about the alignment
+ -- of individual components.
+
+ if Is_Bit_Packed_Array (Ptyp) then
+ return True;
+ end if;
+
+ -- Case of array is part of a selected component reference
+
+ elsif Nkind (Pref) = N_Selected_Component then
+ Ptyp := Etype (Prefix (Pref));
+
+ -- We are definitely in trouble if the record in question
+ -- has an alignment, and either we know this alignment is
+ -- inconsistent with the alignment of the slice, or we
+ -- don't know what the alignment of the slice should be.
+
+ if Known_Alignment (Ptyp)
+ and then (Unknown_Alignment (Styp)
+ or else Alignment (Styp) > Alignment (Ptyp))
+ then
+ return True;
+ end if;
+
+ -- We are in potential trouble if the record type is packed.
+ -- We could special case when we know that the array is the
+ -- first component, but that's not such a simple case ???
+
+ if Is_Packed (Ptyp) then
+ return True;
+ end if;
+
+ -- We are in trouble if there is a component clause, and
+ -- either we do not know the alignment of the slice, or
+ -- the alignment of the slice is inconsistent with the
+ -- bit position specified by the component clause.
+
+ declare
+ Field : constant Entity_Id := Entity (Selector_Name (Pref));
+ begin
+ if Present (Component_Clause (Field))
+ and then
+ (Unknown_Alignment (Styp)
+ or else
+ (Component_Bit_Offset (Field) mod
+ (System_Storage_Unit * Alignment (Styp))) /= 0)
+ then
+ return True;
+ end if;
+ end;
+
+ -- For cases other than selected or indexed components we
+ -- know we are OK, since no issues arise over alignment.
+
+ else
+ return False;
+ end if;
+
+ -- We processed an indexed component or selected component
+ -- reference that looked safe, so keep checking prefixes.
+
+ Pref := Prefix (Pref);
+ end loop;
end;
end Is_Possibly_Unaligned_Slice;
-- Compile without -g
-- Run the program, and call Call_Chain
-- Recompile with -g
--- Use addr2line to interpret the absolute call locations
+-- Use addr2line to interpret the absolute call locations (note that
+-- addr2line expects addresses in hexadecimal format).
-- This capability is currently supported on the following targets:
* Reserved Words::
* Lexical Elements::
* Declarations::
+* Empty declarations::
* Typed string declarations::
* Variables::
* Expressions::
variable_declaration |
typed_variable_declaration |
attribute_declaration |
- case_construction
+ case_construction |
+ empty_declaration
@end smallexample
+@node Empty declarations
+@section Empty declarations
+
+@smallexample
+empty_declaration ::=
+ @b{null} ;
+@end smallexample
+
+An empty declaration is allowed anywhere a declaration is allowed.
+It has no effect.
+
@node Typed string declarations
@section Typed string declarations
case_item ::=
@b{when} discrete_choice_list =>
- @{case_construction | attribute_declaration@}
+ @{case_construction | attribute_declaration | empty_declaration@}
discrete_choice_list ::=
string_literal @{| string_literal@} |
for ^Default_Switches^Default_Switches^ ("Ada")
use ("^-g^-g^");
for Executable ("proc") use "proc1";
+ when others =>
+ null;
end case;
end Builder;
The_Data := Projects.Table (Prj);
end loop;
- if The_Data.Library and then not The_Data.Flag1 then
+ if The_Data.Library
+ and then not The_Data.Need_To_Build_Lib
+ then
-- Add to the Q all sources of the project that
-- have not been marked
-- Now mark the project as processed
- Projects.Table (Prj).Flag1 := True;
+ Projects.Table (Prj).Need_To_Build_Lib := True;
end if;
end;
end if;
if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then
for Proj in Projects.First .. Projects.Last loop
if Projects.Table (Proj).Library then
- Projects.Table (Proj).Flag1 :=
+ Projects.Table (Proj).Need_To_Build_Lib :=
not MLib.Tgt.Library_Exists_For (Proj);
- if Projects.Table (Proj).Flag1 then
+ if Projects.Table (Proj).Need_To_Build_Lib then
if Verbose_Mode then
Write_Str
("Library file does not exist for project """);
end if;
if Projects.Table (Proj1).Library
- and then not Projects.Table (Proj1).Flag1
+ and then not Projects.Table (Proj1).Need_To_Build_Lib
then
MLib.Prj.Check_Library (Proj1);
end if;
- if Projects.Table (Proj1).Flag1 then
+ if Projects.Table (Proj1).Need_To_Build_Lib then
Library_Projs.Increment_Last;
Current := Library_Projs.Last;
Depth := Projects.Table (Proj1).Depth;
end loop;
Library_Projs.Table (Current) := Proj1;
- Projects.Table (Proj1).Flag1 := False;
+ Projects.Table (Proj1).Need_To_Build_Lib := False;
end if;
end loop;
end;
if not Compile_Only then
- -- If there are linking options from the command line,
- -- transmit them to gnatmake.
+ -- Linking options
if Linker_Options.Last /= 0 then
Add_Argument (Dash_largs, True);
-
- for Arg in 1 .. Linker_Options.Last loop
- Add_Argument (Linker_Options.Table (Arg), True);
- end loop;
-
else
Add_Argument (Dash_largs, Verbose_Mode);
end if;
-- Add the archives
Add_Archives (For_Gnatmake => True);
+
+ -- If there are linking options from the command line,
+ -- transmit them to gnatmake.
+
+ for Arg in 1 .. Linker_Options.Last loop
+ Add_Argument (Linker_Options.Table (Arg), True);
+ end loop;
end if;
-- And invoke gnatmake
Get_Name_String (Source.Object_Name),
True);
+ -- Add all the archives, in a correct order
+
+ Add_Archives (For_Gnatmake => False);
+
-- Add the switches specified in package Linker of
-- the main project.
Add_Argument (Linker_Options.Table (Arg), True);
end loop;
- -- Add all the archives, in a correct order
-
- Add_Archives (For_Gnatmake => False);
-
-- If there are shared libraries and the run path
-- option is supported, add the run path switch.
Data : constant Project_Data := Projects.Table (For_Project);
begin
- if Data.Library and not Data.Flag1 then
+ if Data.Library and not Data.Need_To_Build_Lib then
declare
Current : constant Dir_Name_Str := Get_Current_Dir;
Lib_Name : constant Name_Id := Library_File_Name_For (For_Project);
Obj_TS := File_Stamp (Name_Find);
- -- If library file time stamp is earlier, set Flag1 and
- -- return. String comparaison is used, otherwise time stamps
- -- may be too close and the comparaison would return True,
- -- which would trigger an unnecessary rebuild of the
- -- library.
+ -- If library file time stamp is earlier, set
+ -- Need_To_Build_Lib and return. String comparaison is used,
+ -- otherwise time stamps may be too close and the
+ -- comparaison would return True, which would trigger
+ -- an unnecessary rebuild of the library.
if String (Lib_TS) < String (Obj_TS) then
-- Library must be rebuilt
- Projects.Table (For_Project).Flag1 := True;
+ Projects.Table (For_Project).Need_To_Build_Lib := True;
exit;
end if;
end if;
pragma Unreferenced (Lib_Version);
Lib_File : constant String :=
- Lib_Dir & Directory_Separator & "lib" &
- MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
+ Lib_Dir & Directory_Separator & "lib" &
+ MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
-- The file name of the library
Init_Fini : Argument_List_Access := Empty_Argument_List;
pragma Unreferenced (Symbol_Data);
Lib_File : constant String :=
- Lib_Dir & Directory_Separator & "lib" &
- MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
+ Lib_Dir & Directory_Separator & "lib" &
+ MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
Version_Arg : String_Access;
Symbolic_Link_Needed : Boolean := False;
end if;
-- If specified, add automatic elaboration/finalization
+
if Auto_Init then
Init_Fini := Init_Fini_List;
Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init");
pragma Unreferenced (Symbol_Data);
Lib_File : constant String :=
- Lib_Dir & Directory_Separator & "lib" &
- MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
+ Lib_Dir & Directory_Separator & "lib" &
+ MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
Version_Arg : String_Access;
Symbolic_Link_Needed : Boolean := False;
end if;
-- If specified, add automatic elaboration/finalization
+
if Auto_Init then
Init_Fini := Init_Fini_List;
Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init");
pragma Unreferenced (Symbol_Data);
Lib_File : constant String :=
- Lib_Dir & Directory_Separator & "lib" &
- Fil.Ext_To (Lib_Filename, DLL_Ext);
+ Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Filename, DLL_Ext);
Version_Arg : String_Access;
Symbolic_Link_Needed : Boolean := False;
end if;
-- If specified, add automatic elaboration/finalization
+
if Auto_Init then
Init_Fini := Init_Fini_List;
Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init");
pragma Unreferenced (Lib_Version);
Lib_File : constant String :=
- Lib_Dir & Directory_Separator &
- Files.Ext_To (Lib_Filename, DLL_Ext);
+ Lib_Dir & Directory_Separator &
+ Files.Ext_To (Lib_Filename, DLL_Ext);
-- Start of processing for Build_Dynamic_Library
else
return Is_Regular_File
- (Lib_Dir & Directory_Separator & "lib" &
+ (Lib_Dir & Directory_Separator &
MLib.Fil.Ext_To (Lib_Name, DLL_Ext));
end if;
end;
Get_Name_String (Projects.Table (Project).Library_Name);
begin
- Name_Len := 3;
- Name_Buffer (1 .. Name_Len) := "lib";
-
if Projects.Table (Project).Library_Kind = Static then
+ Name_Len := 3;
+ Name_Buffer (1 .. Name_Len) := "lib";
Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
else
+ Name_Len := 0;
Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
end if;
pragma Unreferenced (Symbol_Data);
Lib_File : constant String :=
- Lib_Dir & Directory_Separator & "lib" &
- Fil.Ext_To (Lib_Filename, DLL_Ext);
+ Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Filename, DLL_Ext);
Version_Arg : String_Access;
Symbolic_Link_Needed : Boolean := False;
end if;
-- If specified, add automatic elaboration/finalization
+
if Auto_Init then
Init_Fini := Init_Fini_List;
Init_Fini (1) :=
pragma Unreferenced (Symbol_Data);
Lib_File : constant String :=
- Lib_Dir & Directory_Separator & "lib" &
- Fil.Ext_To (Lib_Filename, DLL_Ext);
+ Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Filename, DLL_Ext);
Version_Arg : String_Access;
Symbolic_Link_Needed : Boolean := False;
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
- Fil.Ext_To (Lib_Filename, DLL_Ext);
+ Fil.Ext_To (Lib_Filename, DLL_Ext);
Opts : Argument_List := Options;
Last_Opt : Natural := Opts'Last;
function Is_Interface (Obj_File : String) return Boolean;
-- For a Stand-Alone Library, returns True if Obj_File is the object
- -- file name of an interface of the SAL.
- -- For other libraries, always return True.
+ -- file name of an interface of the SAL. For other libraries, always
+ -- return True.
function Option_File_Name return String;
-- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
- Fil.Ext_To (Lib_Filename, DLL_Ext);
+ Fil.Ext_To (Lib_Filename, DLL_Ext);
Opts : Argument_List := Options;
Last_Opt : Natural := Opts'Last;
function Is_Interface (Obj_File : String) return Boolean;
-- For a Stand-Alone Library, returns True if Obj_File is the object
- -- file name of an interface of the SAL.
- -- For other libraries, always return True.
+ -- file name of an interface of the SAL. For other libraries, always
+ -- return True.
function Option_File_Name return String;
-- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"
Set_End_Of_Line (Current_Declaration);
Set_Previous_Line_Node (Current_Declaration);
+ when Tok_Null =>
+
+ Scan; -- past "null"
+
when Tok_Package =>
-- Package declaration
First_Referred_By => No_Project,
Name => No_Name,
Path_Name => No_Name,
- Virtual => False,
Display_Path_Name => No_Name,
+ Virtual => False,
Location => No_Location,
Mains => Nil_String,
Directory => No_Name,
Language_Independent_Checked => False,
Checked => False,
Seen => False,
- Flag1 => False,
- Flag2 => False,
+ Need_To_Build_Lib => False,
Depth => 0,
Unkept_Comments => False);
package Prj is
Empty_Name : Name_Id;
- -- Name_Id for an empty name (no characters).
- -- Initialized by procedure Initialize.
+ -- Name_Id for an empty name (no characters). Initialized by the call
+ -- to procedure Initialize.
All_Packages : constant String_List_Access := null;
-- Default value of parameter Packages of procedures Parse, in Prj.Pars and
-- normally forbidden for project names, there cannot be any name clash.
Project_File_Extension : String := ".gpr";
- -- The standard project file name extension.
- -- It is not a constant, because Canonical_Case_File_Name is called
- -- on this variable in the body of Prj.
+ -- The standard project file name extension. It is not a constant, because
+ -- Canonical_Case_File_Name is called on this variable in the body of Prj.
Default_Ada_Spec_Suffix : Name_Id;
-- The Name_Id for the standard GNAT suffix for Ada spec source file
type Programming_Language is
(Lang_Ada, Lang_C, Lang_C_Plus_Plus);
- -- The list of language supported
+ -- The set of languages supported
subtype Other_Programming_Language is
- Programming_Language range Lang_C .. Programming_Language'Last;
+ Programming_Language range Lang_C .. Programming_Language'Last;
+ -- The set of non-Ada languages supported
+
type Languages_In_Project is array (Programming_Language) of Boolean;
+ -- Set of supported languages used in a project
+
No_Languages : constant Languages_In_Project := (others => False);
+ -- No supported languages are used
type Impl_Suffix_Array is array (Programming_Language) of Name_Id;
+ -- Suffixes for the non spec sources of the different supported languages
+ -- in a project.
+
No_Impl_Suffixes : constant Impl_Suffix_Array := (others => No_Name);
+ -- A default value for the non spec source suffixes
Lang_Ada_Name : aliased String := "ada";
Lang_C_Name : aliased String := "c";
-- -x when using a GCC compiler.
Lang_Name_Ids : array (Programming_Language) of Name_Id;
- -- Initialized by Prj.Initialize
+ -- Same as Lang_Names, but using Name_Id, instead of String_Access.
+ -- Initialized by Prj.Initialize.
Lang_Ada_Display_Name : aliased String := "Ada";
Lang_C_Display_Name : aliased String := "C";
Lang_C_Plus_Plus => C_Plus_Plus_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
+ Lang_Suffix_Ids : array (Programming_Language) of Name_Id;
+ -- Same as Lang_Suffixes, but using Name_Id, instead of String_Access.
+ -- Initialized by Prj.Initialize.
Gnatmake_String : aliased String := "gnatmake";
Gcc_String : aliased String := "gcc";
(Lang_Ada => Ada_Args_Strings 'Access,
Lang_C => C_Args_String 'Access,
Lang_C_Plus_Plus => C_Plus_Plus_Args_String'Access);
+ -- For each supported language, the string between "-c" and "args" to
+ -- be used in the gprmake switch for the start of the compiling switch
+ -- section for each supported language. For example, "-ccargs" indicates
+ -- the start of the C compiler switch section.
type Other_Source_Id is new Nat;
No_Other_Source : constant Other_Source_Id := 0;
Naming_Exception : Boolean := False; -- True if a naming exception
Next : Other_Source_Id := No_Other_Source;
end record;
+ -- Data for a source in a language other than Ada
package Other_Sources is new Table.Table
(Table_Component_Type => Other_Source,
-- High is extremely verbose.
type Lib_Kind is (Static, Dynamic, Relocatable);
-
type Policy is (Autonomous, Compliant, Controlled, Restricted);
- -- See explaination about this type in package Symbols
+ -- Type to specify the symbol policy, when symbol control is supported.
+ -- See full explanation about this type in package Symbols.
+ -- Autonomous: Create a symbol file without considering any reference
+ -- Compliant: Try to be as compatible as possible with an existing ref
+ -- Controlled: Fail if symbols are not the same as those in the reference
+ -- Restricted: Restrict the symbols to those in the symbol file
type Symbol_Record is record
Symbol_File : Name_Id := No_Name;
(Symbol_File => No_Name,
Reference => No_Name,
Symbol_Policy => Autonomous);
+ -- The default value of the symbol data
function Empty_String return Name_Id;
+ -- Return the Name_Id for an empty string ""
type Project_Id is new Nat;
No_Project : constant Project_Id := 0;
Index : Int := 0;
end case;
end record;
- -- Values for variables and array elements.
- -- Default is True if the current value is the default one for the variable
+ -- Values for variables and array elements. Default is True if the
+ -- current value is the default one for the variable
Nil_Variable_Value : constant Variable_Value :=
(Project => No_Project,
Arrays : Array_Id := No_Array;
Packages : Package_Id := No_Package;
end record;
+ -- Contains the declarations (variables, single and array attributes,
+ -- packages) for a project or a package in a project.
No_Declarations : constant Declarations :=
(Variables => No_Variable,
Attributes => No_Variable,
Arrays => No_Array,
Packages => No_Package);
- -- Declarations. Used in project structures and packages (what for???)
+ -- Default value of Declarations: indicates that there is no declarations.
type Package_Element is record
Name : Name_Id := No_Name;
-- Current_Body_Suffix is defined.
Separate_Suffix : Name_Id := No_Name;
- -- The string to append to the unit name for the
- -- source file name of an Ada subunit.
+ -- String to append to unit name for source file name of an Ada subunit.
Sep_Suffix_Loc : Source_Ptr := No_Location;
- -- The position in the project file source where
- -- Separate_Suffix is defined.
+ -- Position in the project file source where Separate_Suffix is defined.
Specs : Array_Element_Id := No_Array_Element;
- -- An associative array mapping individual specs
- -- to source file names. Specific to Ada.
+ -- An associative array mapping individual specs to source file names.
+ -- This is specific to Ada.
Bodies : Array_Element_Id := No_Array_Element;
- -- An associative array mapping individual bodies
- -- to source file names. Specific to Ada.
+ -- An associative array mapping individual bodies to source file names.
+ -- This is specific to Ada.
Specification_Exceptions : Array_Element_Id := No_Array_Element;
- -- An associative array listing spec file names that don't have the
- -- spec suffix. Not used by Ada. Indexed by the programming language
- -- name.
+ -- An associative array listing spec file names that do not have the
+ -- spec suffix. Not used by Ada. Indexed by programming language name.
Implementation_Exceptions : Array_Element_Id := No_Array_Element;
- -- An associative array listing body file names that don't have the
- -- body suffix. Not used by Ada. Indexed by the programming language
- -- name.
+ -- An associative array listing body file names that do not have the
+ -- body suffix. Not used by Ada. Indexed by programming language name.
end record;
function Standard_Naming_Data return Naming_Data;
pragma Inline (Standard_Naming_Data);
- -- The standard GNAT naming scheme.
+ -- The standard GNAT naming scheme
function Same_Naming_Scheme
(Left, Right : Naming_Data)
type Project_List is new Nat;
Empty_Project_List : constant Project_List := 0;
- -- A list of project files.
+ -- A list of project files
type Project_Element is record
Project : Project_Id := No_Project;
Next : Project_List := Empty_Project_List;
end record;
- -- Element in a list of project file.
- -- Next is the id of the next project file in the list.
+ -- Element in a list of project files. Next is the id of the next
+ -- project file in the list.
package Project_Lists is new Table.Table
(Table_Component_Type => Project_Element,
Table_Initial => 100,
Table_Increment => 100,
Table_Name => "Prj.Project_Lists");
- -- The table that contains the lists of project files.
+ -- The table that contains the lists of project files
-- The following record describes a project file representation
-- Set by Prj.Proc.Process.
Name : Name_Id := No_Name;
- -- The name of the project.
- -- Set by Prj.Proc.Process.
+ -- The name of the project. Set by Prj.Proc.Process.
Path_Name : Name_Id := No_Name;
- -- The path name of the project file.
- -- Set by Prj.Proc.Process.
+ -- The path name of the project file. Set by Prj.Proc.Process.
+
+ Display_Path_Name : Name_Id := No_Name;
+ -- The path name used for display purposes. May be different from
+ -- Path_Name for platforms where the file names are case-insensitive.
Virtual : Boolean := False;
-- True for virtual extending projects
- Display_Path_Name : Name_Id := No_Name;
-
Location : Source_Ptr := No_Location;
- -- The location in the project file source of the
- -- reserved word project.
- -- Set by Prj.Proc.Process.
+ -- The location in the project file source of the reserved word
+ -- project. Set by Prj.Proc.Process.
Mains : String_List_Id := Nil_String;
- -- The list of mains as specified by attribute Main.
- -- Set by Prj.Nmsc.Ada_Check.
+ -- List of mains specified by attribute Main. Set by Prj.Nmsc.Ada_Check.
Directory : Name_Id := No_Name;
- -- The directory where the project file resides.
- -- Set by Prj.Proc.Process.
+ -- Directory where the project file resides. Set by Prj.Proc.Process.
Display_Directory : Name_Id := No_Name;
-- Set by Prj.Nmsc.Language_Independent_Check.
Display_Library_Dir : Name_Id := No_Name;
+ -- The name of the library directory, for display purposes.
+ -- May be different from Library_Dir for platforms where the file names
+ -- are case-insensitive.
Library_Src_Dir : Name_Id := No_Name;
-- If a library project, directory where the sources and the ALI files
-- Set by Prj.Nmsc.Language_Independent_Check.
Display_Library_Src_Dir : Name_Id := No_Name;
+ -- The name of the library source directory, for display purposes.
+ -- May be different from Library_Src_Dir for platforms where the file
+ -- names are case-insensitive.
Library_Name : Name_Id := No_Name;
-- If a library project, name of the library
Lib_Interface_ALIs : String_List_Id := Nil_String;
-- For Standalone Library Project Files, indicate the list
- -- of Interface ALI files.
- -- Set by Prj.Nmsc.Ada_Check.
+ -- of Interface ALI files. Set by Prj.Nmsc.Ada_Check.
- Lib_Auto_Init : Boolean := False;
+ Lib_Auto_Init : Boolean := False;
-- For non static Standalone Library Project Files, indicate if
-- the library initialisation should be automatic.
Ada_Sources_Present : Boolean := True;
-- A flag that indicates if there are Ada sources in this project file.
- -- There are no sources if 1) Source_Dirs is specified as an
- -- empty list, 2) Source_Files is specified as an empty list, or
- -- 3) Ada is not in the list of the specified Languages.
+ -- There are no sources if any of the following is true:
+ -- 1) Source_Dirs is specified as an empty list
+ -- 2) Source_Files is specified as an empty list
+ -- 3) Ada is not in the list of the specified Languages
- Other_Sources_Present : Boolean := True;
+ Other_Sources_Present : Boolean := True;
-- A flag that indicates that there are non-Ada sources in this project
Sources : String_List_Id := Nil_String;
- -- The list of all the source file names.
- -- Set by Prj.Nmsc.Check_Ada_Naming_Scheme.
+ -- The list of all the source file names. Set by
+ -- Prj.Nmsc.Check_Ada_Naming_Scheme.
First_Other_Source : Other_Source_Id := No_Other_Source;
Last_Other_Source : Other_Source_Id := No_Other_Source;
-- -I switches.
Include_Data_Set : Boolean := False;
- -- Set to True when Imported_Directories_Switches or Include_Path are
- -- set.
+ -- Set 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.Language_Independent_Check.
Display_Object_Dir : Name_Id := No_Name;
+ -- The name of the object directory, for display purposes.
+ -- May be different from Object_Directory for platforms where the file
+ -- names are case-insensitive.
- Exec_Directory : Name_Id := No_Name;
- -- The exec directory of this project file.
- -- Default is equal to Object_Directory.
- -- Set by Prj.Nmsc.Language_Independent_Check.
+ Exec_Directory : Name_Id := No_Name;
+ -- The exec directory of this project file. Default is equal to
+ -- Object_Directory. Set by Prj.Nmsc.Language_Independent_Check.
Display_Exec_Dir : Name_Id := No_Name;
+ -- The name of the exec directory, for display purposes.
+ -- May be different from Exec_Directory for platforms where the file
+ -- names are case-insensitive.
Extends : Project_Id := No_Project;
-- The reference of the project file, if any, that this
- -- project file extends.
- -- Set by Prj.Proc.Process.
+ -- project file extends. Set by Prj.Proc.Process.
Extended_By : Project_Id := No_Project;
-- The reference of the project file, if any, that
- -- extends this project file.
- -- Set by Prj.Proc.Process.
+ -- extends this project file. Set by Prj.Proc.Process.
Naming : Naming_Data := Standard_Naming_Data;
-- The naming scheme of this project file.
-- Set by Prj.Nmsc.Check_Naming_Scheme.
Decl : Declarations := No_Declarations;
- -- The declarations (variables, attributes and packages)
- -- of this project file.
- -- Set by Prj.Proc.Process.
+ -- The declarations (variables, attributes and packages) of this
+ -- project file. Set by Prj.Proc.Process.
Imported_Projects : Project_List := Empty_Project_List;
-- The list of all directly imported projects, if any.
-- Set by Prj.Proc.Process.
- Ada_Include_Path : String_Access := null;
+ Ada_Include_Path : String_Access := null;
-- The cached value of ADA_INCLUDE_PATH for this project file.
-- Do not use this field directly outside of the compiler, use
- -- Prj.Env.Ada_Include_Path instead.
- -- Set by Prj.Env.Ada_Include_Path.
+ -- Prj.Env.Ada_Include_Path instead. Set by Prj.Env.Ada_Include_Path.
- Ada_Objects_Path : String_Access := null;
+ Ada_Objects_Path : String_Access := null;
-- The cached value of ADA_OBJECTS_PATH for this project file.
-- Do not use this field directly outside of the compiler, use
- -- Prj.Env.Ada_Objects_Path instead.
- -- Set by Prj.Env.Ada_Objects_Path
+ -- Prj.Env.Ada_Objects_Path instead. Set by Prj.Env.Ada_Objects_Path
Include_Path_File : Name_Id := No_Name;
-- The cached value of the source path temp file for this project file.
Objects_Path_File_With_Libs : Name_Id := No_Name;
-- The cached value of the object path temp file (including library
- -- dirs) for this project file.
- -- Set by gnatmake (Prj.Env.Set_Ada_Paths).
+ -- dirs) for this project file. Set by gnatmake (Prj.Env.Set_Ada_Paths).
Objects_Path_File_Without_Libs : Name_Id := No_Name;
-- The cached value of the object path temp file (excluding library
- -- dirs) for this project file.
- -- Set by gnatmake (Prj.Env.Set_Ada_Paths).
+ -- dirs) for this project file. Set by gnatmake (Prj.Env.Set_Ada_Paths).
Config_File_Name : Name_Id := No_Name;
-- The name of the configuration pragmas file, if any.
Checked : Boolean := False;
-- A flag to avoid checking repetitively the naming scheme of
- -- this project file.
- -- Set by Prj.Nmsc.Check_Ada_Naming_Scheme.
-
- Seen : Boolean := False;
- Flag1 : Boolean := False;
- Flag2 : Boolean := False;
- -- Various flags that are used in an ad hoc manner
- -- That's really not a good enough comment ??? we need to know what
- -- these flags are used for, and give them proper names. If Flag1
- -- and Flag2 have multiple uses, then either we use multiple fields
- -- or a renaming scheme.
+ -- this project file. Set by Prj.Nmsc.Check_Ada_Naming_Scheme.
+
+ Seen : Boolean := False;
+ -- A flag to mark a project as "visited" to avoid processing the same
+ -- project several time.
+
+ Need_To_Build_Lib : Boolean := False;
+ -- Indicates that the library of a Library Project needs to be built or
+ -- rebuilt.
Depth : Natural := 0;
-- The maximum depth of a project in the project graph.
end record;
function Empty_Project return Project_Data;
- -- Return the representation of an empty project.
+ -- Return the representation of an empty project
package Projects is new Table.Table (
Table_Component_Type => Project_Data,
Table_Initial => 100,
Table_Increment => 100,
Table_Name => "Prj.Projects");
- -- The set of all project files.
+ -- The set of all project files
type Put_Line_Access is access procedure
(Line : String;
Project : Project_Id);
- -- Use to customize error reporting in Prj.Proc and Prj.Nmsc.
+ -- Use to customize error reporting in Prj.Proc and Prj.Nmsc
procedure Expect (The_Token : Token_Type; Token_Image : String);
-- Check that the current token is The_Token. If it is not, then
-- project file tree. Initialize must be called before the call to Reset.
procedure Register_Default_Naming_Scheme
- (Language : Name_Id;
+ (Language : Name_Id;
Default_Spec_Suffix : Name_Id;
Default_Body_Suffix : Name_Id);
-- Register the default suffixs for a given language. These extensions
private
Initial_Buffer_Size : constant := 100;
+ -- Initial size for extensible buffer used below
Buffer : String_Access := new String (1 .. Initial_Buffer_Size);
-- An extensible character buffer to store names. Used in Prj.Part and
-- a unit is loaded to contain the defining entity for the unit, the
-- unit name, and the unit number.
+ -- Note that a unit can be loaded either by a call to find an entity
+ -- within the unit (e.g. RTE), or by an explicit with of the unit. In
+ -- the latter case it is critical to make a call to Set_RTU_Loaded to
+ -- ensure that the entry in this table reflects the load.
+
type RT_Unit_Table_Record is record
Entity : Entity_Id;
Uname : Unit_Name_Type;
function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type;
-- Retrieves the Unit Name given a unit id represented by its
- -- enumaration value in RTU_Id.
+ -- enumeration value in RTU_Id.
procedure Load_RTU
(U_Id : RTU_Id;
-- a WITH if the current unit is part of the extended main code
-- unit, and if we have not already added the with. The WITH is
-- added to the appropriate unit (the current one). We do not need
- -- to generate a WITH for an
+ -- to generate a WITH for an ????
<<Found>>
if (not U.Withed)
function RTU_Loaded (U : RTU_Id) return Boolean is
begin
- return True or else Present (RT_Unit_Table (U).Entity);
- -- Temporary kludge until we get proper interaction to ensure that
- -- an explicit WITH of a unit is properly registered in rtsfind ???
+ return Present (RT_Unit_Table (U).Entity);
end RTU_Loaded;
+ --------------------
+ -- Set_RTU_Loaded --
+ --------------------
+
+ procedure Set_RTU_Loaded (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
+ Uname : constant Unit_Name_Type := Unit_Name (Unum);
+ E : constant Entity_Id :=
+ Defining_Entity (Unit (Cunit (Unum)));
+ begin
+ pragma Assert (Is_Predefined_File_Name (Unit_File_Name (Unum)));
+
+ -- Loop through entries in RTU table looking for matching entry
+
+ for U_Id in RTU_Id'Range loop
+
+ -- Here we have a match
+
+ if Get_Unit_Name (U_Id) = Uname then
+ declare
+ U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
+ -- The RT_Unit_Table entry that may need updating
+
+ begin
+ -- If entry is not set, set it now
+
+ if not Present (U.Entity) then
+ U.Entity := E;
+ U.Uname := Get_Unit_Name (U_Id);
+ U.Unum := Unum;
+ U.Withed := False;
+ end if;
+
+ return;
+ end;
+ end if;
+ end loop;
+ end Set_RTU_Loaded;
+
--------------------
-- Text_IO_Kludge --
--------------------
--
-- If RTE returns, the returned value is the required entity
--
- -- If the entity is not available, then an error message is given The
+ -- If the entity is not available, then an error message is given. The
-- form of the message depends on whether we are in configurable run time
-- mode or not. In configurable run time mode, a missing entity is not
-- that surprising and merely says that the particular construct is not
-- If the unit has not been loaded, returns False. Note that this does
-- not mean that an attempt to load it subsequently would fail.
+ procedure Set_RTU_Loaded (N : Node_Id);
+ -- Register the predefined unit N as already loaded.
+
procedure Text_IO_Kludge (Nam : Node_Id);
-- In Ada 83, and hence for compatibility in Ada 9X, package Text_IO has
-- generic subpackages (e.g. Integer_IO). They really should be child
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
Set_Acts_As_Spec (N);
end if;
+ -- Register predefined units in Rtsfind
+
+ declare
+ Unum : constant Unit_Number_Type := Get_Source_Unit (Sloc (N));
+ begin
+ if Is_Predefined_File_Name (Unit_File_Name (Unum)) then
+ Set_RTU_Loaded (Unit_Node);
+ end if;
+ end;
+
-- Treat compilation unit pragmas that appear after the library unit
if Present (Pragmas_After (Aux_Decls_Node (N))) then
Next_Non_Pragma (Formal_Node);
else
- -- No further formals to match.
+ -- No further formals to match, but the generic
+ -- part may contain inherited operation that are
+ -- not hidden in the enclosing instance.
- exit;
+ Next_Entity (Actual_Ent);
end if;
end loop;
-- hides the implicit one, which is removed from all visibility,
-- i.e. the entity list of its scope, and homonym chain of its name.
- elsif (Is_Overloadable (E) and then Present (Alias (E)))
+ elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
or else Is_Internal (E)
- or else (Ekind (E) = E_Enumeration_Literal
- and then Is_Derived_Type (Etype (E)))
then
declare
Prev : Entity_Id;
if Is_Private_Type (Btype)
and then not Is_Generic_Type (Btype)
then
- return Btype;
+ if Present (Full_View (Btype))
+ and then Is_Record_Type (Full_View (Btype))
+ and then not Is_Frozen (Btype)
+ then
+ -- To indicate that the ancestor depends on a private type,
+ -- the current Btype is sufficient. However, to check for
+ -- circular definition we must recurse on the full view.
+
+ Candidate := Trace_Components (Full_View (Btype), True);
+
+ if Candidate = Any_Type then
+ return Any_Type;
+ else
+ return Btype;
+ end if;
+
+ else
+ return Btype;
+ end if;
elsif Is_Array_Type (Btype) then
return Trace_Components (Component_Type (Btype), True);
projects / gcc.git / commitdiff