Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Lib_Version);
pragma Unreferenced (Relocatable);
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
-- Options to use when invoking gcc to build the dynamic library
No_Start_Files : aliased String := "-nostartfiles";
- For_Linker_Opt : aliased String := "--for-linker=symvec.opt";
- Gsmatch : aliased String := "--for-linker=gsmatch=equal,1,0";
- VMS_Options : constant Argument_List :=
- (No_Start_Files'Access, For_Linker_Opt'Access, Gsmatch'Access);
-
--- Command : String_Access;
+ VMS_Options : Argument_List :=
+ (No_Start_Files'Access, null);
Gnatsym_Name : constant String := "gnatsym";
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Lib_Address);
- pragma Unreferenced (Lib_Version);
pragma Unreferenced (Relocatable);
- Opt_File_Name : constant String := "symvec.opt";
+
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
-- 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"
+
+ function Version_String return String;
+ -- Returns Lib_Version if not empty, otherwise returns "1".
+ -- Fails gnatmake if Lib_Version is not the image of a positive number.
+
------------------
-- Is_Interface --
------------------
end if;
end Is_Interface;
+ ----------------------
+ -- Option_File_Name --
+ ----------------------
+
+ function Option_File_Name return String is
+ begin
+ if Symbol_Data.Symbol_File = No_Name then
+ return "symvec.opt";
+
+ else
+ return Get_Name_String (Symbol_Data.Symbol_File);
+ end if;
+ end Option_File_Name;
+
+ --------------------
+ -- Version_String --
+ --------------------
+
+ function Version_String return String is
+ Version : Integer := 0;
+ begin
+ if Lib_Version = "" then
+ return "1";
+
+ else
+ begin
+ Version := Integer'Value (Lib_Version);
+
+ if Version <= 0 then
+ raise Constraint_Error;
+ end if;
+
+ return Lib_Version;
+
+ exception
+ when Constraint_Error =>
+ Fail ("illegal version """, Lib_Version,
+ """ (on VMS version must be a positive number)");
+ return "";
+ end;
+ end if;
+ end Version_String;
+
+ Opt_File_Name : constant String := Option_File_Name;
+ For_Linker_Opt : constant String_Access :=
+ new String'("--for-linker=" & Opt_File_Name);
+ Version : constant String := Version_String;
+
begin
+ VMS_Options (VMS_Options'First + 1) := For_Linker_Opt;
+
for J in Inter'Range loop
To_Lower (Inter (J).all);
end loop;
end;
end if;
- -- Allocate the argument list and put the symbol file name
+ -- Allocate the argument list and put the symbol file name, the
+ -- reference (if any) and the policy (if not autonomous).
- Arguments := new Argument_List (1 .. Ofiles'Length + 2);
+ Arguments := new Argument_List (1 .. Ofiles'Length + 8);
- Last_Argument := 1;
+ Last_Argument := 0;
+
+ -- Verbosity
if Verbose_Mode then
+ Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-v");
+ end if;
+
+ -- Version number (major ID)
+
+ if Lib_Version /= "" then
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-V");
Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'(Version);
end if;
+ -- Symbol file
+
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-s");
+ Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'(Opt_File_Name);
+ -- Reference Symbol File
+
+ if Symbol_Data.Reference /= No_Name then
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-r");
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) :=
+ new String'(Get_Name_String (Symbol_Data.Reference));
+ end if;
+
+ -- Policy
+
+ case Symbol_Data.Symbol_Policy is
+ when Autonomous =>
+ null;
+
+ when Compliant =>
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-c");
+
+ when Controlled =>
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-C");
+ end case;
+
-- Add each relevant object file
for Index in Ofiles'Range loop
Symbol_Vector : constant String := "SYMBOL_VECTOR=(";
Equal_Data : constant String := "=DATA)";
Equal_Procedure : constant String := "=PROCEDURE)";
+ Gsmatch : constant String := "gsmatch=equal,";
Symbol_File_Name : String_Access := null;
-- Name of the symbol file
+ Sym_Policy : Policy := Autonomous;
+ -- The symbol policy. Set by Initialize
+
+ Major_ID : Integer := 1;
+ -- The Major ID. May be modified by Initialize if Library_Version is
+ -- specified or if it is read from the reference symbol file.
+
+ Soft_Major_ID : Boolean := True;
+ -- False if library version is specified in procedure Initialize.
+ -- When True, Major_ID may be modified if found in the reference symbol
+ -- file.
+
+ Minor_ID : Natural := 0;
+ -- The Minor ID. May be modified if read from the reference symbol file
+
+ Soft_Minor_ID : Boolean := True;
+ -- False if symbol policy is Autonomous, if library version is specified
+ -- in procedure Initialize and is not the same as the major ID read from
+ -- the reference symbol file. When True, Minor_ID may be increased in
+ -- Compliant symbol policy.
+
subtype Byte is Character;
-- Object files are stream of bytes, but some of these bytes, those for
-- the names of the symbols, are ASCII characters.
Number_Of_Characters : Natural := 0;
-- The number of characters of each section
+ -- The following variables are used by procedure Process when reading an
+ -- object file.
+
Code : Number := 0;
Length : Natural := 0;
procedure Get (N : out Natural);
-- Read two bytes from the object file, LSByte first, as a Natural
+
+ function Image (N : Integer) return String;
+ -- Returns the image of N, without the initial space
+
-----------
-- Equal --
-----------
N := Natural (Result);
end Get;
+ -----------
+ -- Image --
+ -----------
+
+ function Image (N : Integer) return String is
+ Result : constant String := N'Img;
+ begin
+ if Result (Result'First) = ' ' then
+ return Result (Result'First + 1 .. Result'Last);
+
+ else
+ return Result;
+ end if;
+ end Image;
+
----------------
-- Initialize --
----------------
procedure Initialize
- (Symbol_File : String;
- Force : Boolean;
- Quiet : Boolean;
- Success : out Boolean)
+ (Symbol_File : String;
+ Reference : String;
+ Symbol_Policy : Policy;
+ Quiet : Boolean;
+ Version : String;
+ Success : out Boolean)
is
File : Ada.Text_IO.File_Type;
Line : String (1 .. 1_000);
Symbol_File_Name := new String'(Symbol_File);
+ -- Record the policy
+
+ Sym_Policy := Symbol_Policy;
+
+ -- Record the version (Major ID)
+
+ if Version = "" then
+ Major_ID := 1;
+ Soft_Major_ID := True;
+
+ else
+ begin
+ Major_ID := Integer'Value (Version);
+ Soft_Major_ID := False;
+
+ if Major_ID <= 0 then
+ raise Constraint_Error;
+ end if;
+
+ exception
+ when Constraint_Error =>
+ if not Quiet then
+ Put_Line ("Version """ & Version & """ is illegal.");
+ Put_Line ("On VMS, version must be a positive number");
+ end if;
+
+ Success := False;
+ return;
+ end;
+ end if;
+
+ Minor_ID := 0;
+ Soft_Minor_ID := Sym_Policy /= Autonomous;
+
-- Empty the symbol tables
Symbol_Table.Set_Last (Original_Symbols, 0);
Success := True;
- -- If Force is not set, attempt to read the symbol file
+ -- If policy is not autonomous, attempt to read the reference file
- if not Force then
+ if Sym_Policy /= Autonomous then
begin
- Open (File, In_File, Symbol_File);
+ Open (File, In_File, Reference);
exception
when Ada.Text_IO.Name_Error =>
when X : others =>
if not Quiet then
- Put_Line ("could not open """ & Symbol_File & """");
+ Put_Line ("could not open """ & Reference & """");
Put_Line (Exception_Message (X));
end if;
return;
end;
+ -- Read line by line
+
while not End_Of_File (File) loop
Get_Line (File, Line, Last);
+ -- Ignore empty lines
+
if Last = 0 then
null;
+ -- Ignore lines starting with "case_sensitive="
+
elsif Last > Case_Sensitive'Length
and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive
then
null;
+ -- Line starting with "SYMBOL_VECTOR=("
+
elsif Last > Symbol_Vector'Length
and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector
then
+
+ -- SYMBOL_VECTOR=(<symbol>=DATA)
+
if Last > Symbol_Vector'Length + Equal_Data'Length and then
Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data
then
Kind => Data,
Present => True);
+ -- SYMBOL_VECTOR=(<symbol>=PROCEDURE)
+
elsif Last > Symbol_Vector'Length + Equal_Procedure'Length
and then
Line (Last - Equal_Procedure'Length + 1 .. Last) =
Kind => Proc,
Present => True);
+ -- Anything else is incorrectly formatted
+
else
if not Quiet then
- Put_Line ("symbol file """ & Symbol_File &
+ Put_Line ("symbol file """ & Reference &
""" is incorrectly formatted:");
Put_Line ("""" & Line (1 .. Last) & """");
end if;
return;
end if;
+ -- Lines with "gsmatch=equal,<Major_ID>,<Minor_Id>
+
+ elsif Last > Gsmatch'Length
+ and then Line (1 .. Gsmatch'Length) = Gsmatch
+ then
+ declare
+ Start : Positive := Gsmatch'Length + 1;
+ Finish : Positive := Start;
+ OK : Boolean := True;
+ ID : Integer;
+
+ begin
+ loop
+ if Line (Finish) not in '0' .. '9'
+ or else Finish >= Last - 1
+ then
+ OK := False;
+ exit;
+ end if;
+
+ exit when Line (Finish + 1) = ',';
+
+ Finish := Finish + 1;
+ end loop;
+
+ if OK then
+ ID := Integer'Value (Line (Start .. Finish));
+ OK := ID /= 0;
+
+ -- If Soft_Major_ID is True, it means that
+ -- Library_Version was not specified.
+
+ if Soft_Major_ID then
+ Major_ID := ID;
+
+ -- If the Major ID in the reference file is different
+ -- from the Library_Version, then the Minor ID will be 0
+ -- because there is no point in taking the Minor ID in
+ -- the reference file, or incrementing it. So, we set
+ -- Soft_Minor_ID to False, so that we don't modify
+ -- the Minor_ID later.
+
+ elsif Major_ID /= ID then
+ Soft_Minor_ID := False;
+ end if;
+
+ Start := Finish + 2;
+ Finish := Start;
+
+ loop
+ if Line (Finish) not in '0' .. '9' then
+ OK := False;
+ exit;
+ end if;
+
+ exit when Finish = Last;
+
+ Finish := Finish + 1;
+ end loop;
+
+ -- Only set Minor_ID if Soft_Minor_ID is True (see above)
+
+ if OK and then Soft_Minor_ID then
+ Minor_ID := Integer'Value (Line (Start .. Finish));
+ end if;
+ end if;
+
+ -- If OK is not True, that means the line is not correctly
+ -- formatted.
+
+ if not OK then
+ if not Quiet then
+ Put_Line ("symbol file """ & Reference &
+ """ is incorrectly formatted");
+ Put_Line ("""" & Line (1 .. Last) & """");
+ end if;
+
+ Close (File);
+ Success := False;
+ return;
+ end if;
+ end;
+
+ -- Anything else is incorrectly formatted
+
else
if not Quiet then
Put_Line ("unexpected line in symbol file """ &
- Symbol_File & """");
+ Reference & """");
Put_Line ("""" & Line (1 .. Last) & """");
end if;
Success : out Boolean)
is
begin
- -- Open the object file. Return with Success = False if this fails.
+ -- Open the object file with Byte_IO. Return with Success = False if
+ -- this fails.
begin
Open (File, In_File, Object_File);
else
- -- First find if the symbols in the symbol file are also in the
- -- object files.
+ -- First find if the symbols in the reference symbol file are also
+ -- in the object files. Note that this is not done if the policy is
+ -- Autonomous, because no reference symbol file has been read.
-- Expect the first symbol in the symbol file to also be the first
-- in Complete_Symbols.
-- If the symbol is not found, mark it as such in the table
if not Found then
- if not Quiet then
+ if (not Quiet) or else Sym_Policy = Controlled then
Put_Line ("symbol """ & S_Data.Name.all &
""" is no longer present in the object files");
end if;
+ if Sym_Policy = Controlled then
+ Success := False;
+ return;
+
+ elsif Soft_Minor_ID then
+ Minor_ID := Minor_ID + 1;
+ Soft_Minor_ID := False;
+ end if;
+
Original_Symbols.Table (Index_1).Present := False;
Free (Original_Symbols.Table (Index_1).Name);
+
+ if Soft_Minor_ID then
+ Minor_ID := Minor_ID + 1;
+ Soft_Minor_ID := False;
+ end if;
end if;
end loop;
S_Data := Complete_Symbols.Table (Index);
if S_Data.Present then
+
+ if Sym_Policy = Controlled then
+ Put_Line ("symbol """ & S_Data.Name.all &
+ """ is not in the reference symbol file");
+ Success := False;
+ return;
+
+ elsif Soft_Minor_ID then
+ Minor_ID := Minor_ID + 1;
+ Soft_Minor_ID := False;
+ end if;
+
Symbol_Table.Increment_Last (Original_Symbols);
Original_Symbols.Table (Symbol_Table.Last (Original_Symbols)) :=
S_Data;
Put (File, Case_Sensitive);
Put_Line (File, "NO");
+ -- Put the version IDs
+
+ Put (File, Gsmatch);
+ Put (File, Image (Major_ID));
+ Put (File, ',');
+ Put_Line (File, Image (Minor_ID));
+
-- And we are done
Close (File);
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
is
pragma Unreferenced (Ofiles);
pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Driver_Name);
pragma Unreferenced (Lib_Version);
pragma Unreferenced (Auto_Init);
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
pragma Unreferenced (Interfaces);
pragma Unreferenced (Lib_Filename);
pragma Unreferenced (Lib_Dir);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Driver_Name);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Lib_Version);
+2003-11-19 Arnaud Charlet <charlet@act-europe.fr>
+
+ * gnatmem.adb: Clean up verbose output.
+
+ * gprcmd.adb: Change copyright to FSF.
+
+2003-11-19 Vincent Celier <celier@gnat.com>
+
+ * symbols.adb: (Initialize): New parameters Reference, Symbol_Policy
+ and Version (ignored).
+
+ * symbols.ads: (Policy): New type
+ (Initialize): New parameter Reference, Symbol_Policy and
+ Library_Version.
+ Remove parameter Force.
+ Minor reformatting.
+
+ * snames.ads, snames.adbadb: New standard names
+ Library_Reference_Symbol_File and Library_Symbol_Policy
+
+ * mlib-prj.adb:
+ (Build_Library): Call Build_Dinamic_Library with the Symbol_Data of the
+ project.
+
+ * mlib-tgt.adb:
+ (Build_Dynamic_Library): New parameter Symbol_Data (ignored)
+
+ * mlib-tgt.ads: (Build_Dynamic_Library): New parameter Symbol_Data
+
+ * prj.adb: (Project_Empty): New component Symbol_Data
+
+ * prj.ads: (Policy, Symbol_Record): New types
+ (Project_Data): New component Symbol_Data
+
+ * prj-attr.adb:
+ New attributes Library_Symbol_File, Library_Symbol_Policy and
+ Library_Reference_Symbol_File.
+
+ * prj-nmsc.adb:
+ (Ada_Check): When project is a Stand-Alone library project, process
+ attribute Library_Symbol_File, Library_Symbol_Policy and
+ Library_Reference_Symbol_File.
+
+ * 5aml-tgt.adb, 5bml-tgt.adb, 5gml-tgt.adb, 5hml-tgt.adb,
+ 5wml-tgt.adb, 5zml-tgt.adb, 5lml-tgt.adb,
+ 5sml-tgt.adb (Build_Dynamic_Library): New parameter
+ Symbol_Data (ignored).
+
+ * 5vml-tgt.adb (VMS_Options): Remove --for-linker=gsmatch=equal,1,0
+ (Build_Dynamic_Library): New parameter Symbol_Data. New internal
+ functions Option_File_Name and Version_String. Set new options of
+ gnatsym related to symbol file, symbol policy and reference symbol
+ file.
+
+ * 5vsymbol.adb:
+ Extensive modifications to take into account the reference symbol file,
+ the symbol policy, the library version and to put in the symbol file the
+ minor and major IDs.
+
+ * bld.adb (Process_Declarative_Items): Put second argument of
+ gprcmd to_absolute between single quotes, to avoid problems with
+ Windows.
+
+ * bld-io.adb: Update Copyright notice.
+ (Flush): Remove last character of a line, if it is a back slash, to
+ avoid make problems.
+
+ * gnatsym.adb:
+ Implement new scheme with reference symbol file and symbol policy.
+
+ * g-os_lib.ads: (Is_Directory): Clarify comment
+
+2003-11-19 Robert Dewar <dewar@gnat.com>
+
+ * atree.adb: Move New_Copy_Tree global variables to head of package
+
+ * errout.adb: Minor reformatting
+
+2003-11-19 Javier Miranda <miranda@gnat.com>
+
+ * sem_ch4.adb: (Diagnose_Call): Improve error message.
+ Add reference to Ada0Y (AI-50217)
+
+ * sem_ch6.adb, sem_ch8.adb, sem_type.adb,
+ sem_util.adb: Add reference to AI-50217
+
+ * sinfo.ads: (N_With_Clause): Document fields referred to AI-50217
+
+ * sprint.adb: Add reference to Ada0Y (AI-50217, AI-287)
+
+ * sem_aggr.adb: Complete documentation of AI-287 changes
+
+ * par-ch4.adb: Document previous changes.
+
+ * lib-load.adb, lib-writ.adb, einfo.ads, par-ch10.adb,
+ sem_cat.adb, sem_ch3.adb, sem_ch10.adb, sem_ch12.adb: Add references to
+ Ada0Y (AI-50217)
+
+ * exp_aggr.adb: Add references to AI-287 in previous changes
+
+2003-11-19 Ed Schonberg <schonberg@gnat.com>
+
+ * exp_ch6.adb:
+ (Add_Call_By_Copy_Node): Do not original node of rewritten expression
+ in the rewriting is the result of an inlined call.
+
+ * exp_ch6.adb (Add_Call_By_Copy_Node): If actual for (in-)out
+ parameter is a type conversion, use original node to construct the
+ post-call assignment, because expression may have been rewritten, e.g.
+ if it is a packed array.
+
+ * sem_attr.adb:
+ (Resolve_Attribute, case 'Constrained): Attribute is legal in an inlined
+ body, just as it is in an instance.
+ Categorization routines
+
+ * sem_ch12.adb (Analyze_Association, Instantiate_Formal_Subprogram,
+ Instantiate_Object): Set proper sloc reference for message on missing
+ actual.
+
+2003-11-19 Thomas Quinot <quinot@act-europe.fr>
+
+ * Makefile.in: Add FreeBSD libgnat pairs.
+
+ * usage.adb: Fix typo in usage message.
+
+2003-11-19 Jerome Guitton <guitton@act-europe.fr>
+
+ * Makefile.in: On powerpc-wrs-vxworksae: Add s-thread.ad?,
+ s-thrini.ad? and s-tiitho.adb to the full runtime, to support the
+ pragma Thread_Body.
+ Remove i-vthrea.ad? and s-tpae65.ad?, not needed anymore.
+
+ * s-thread.adb: This file is now a dummy implementation of
+ System.Thread.
+
+2003-11-19 Sergey Rybin <rybin@act-europe.fr>
+
+ * rtsfind.adb (Initialize): Add initialization for RTE_Is_Available
+
+2003-11-19 Emmanuel Briot <briot@act-europe.fr>
+
+ * xref_lib.adb (Parse_Identifier_Info): Add handling of generic
+ instanciation references in the parent type description.
+
2003-11-18 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* ada-tree.def: (ALLOCATE_EXPR): Class is "2", not "s".
s-parame.ads<5yparame.ads \
s-taprop.adb<5ztaprop.adb \
s-taspri.ads<5ztaspri.ads \
+ s-thread.adb<5zthread.adb \
+ s-thrini.ads<2sthrini.ads \
+ s-thrini.adb<5zthrini.adb \
+ s-tiitho.adb<5ytiitho.adb \
s-tpopsp.adb<5ztpopsp.adb \
s-vxwork.ads<5pvxwork.ads \
g-soccon.ads<3zsoccon.ads \
EXTRA_RAVEN_SOURCES=i-vxwork.ads s-vxwork.ads
EXTRA_RAVEN_OBJS=i-vxwork.o s-vxwork.o
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
- EXTRA_GNATRTL_TASKING_OBJS=i-vthrea.o s-tpae65.o s-vxwork.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-thread.o s-thrini.o
+ EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
HIE_RAVEN_TARGET_PAIRS=\
$(HIE_NONE_TARGET_PAIRS) \
a-reatim.ads<1areatim.ads \
s-soflin.ads<2ssoflin.ads \
s-stalib.adb<1sstalib.adb \
s-stalib.ads<1sstalib.ads \
+ s-thrini.adb<5zthrini.adb \
s-thrini.ads<2sthrini.ads \
s-thrini.adb<5zthrini.adb \
s-tiitho.adb<5ytiitho.adb \
endif
endif
+ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<45intnam.ads \
+ g-soccon.ads<35soccon.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-mastop.adb<5omastop.adb \
+ s-osinte.adb<55osinte.adb \
+ s-osinte.ads<55osinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<7stpopsp.adb \
+ system.ads<56system.ads
+
+ THREADSLIB=
+ LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+endif
+
ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
ifeq ($(strip $(filter-out mips sgi irix6%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \
Table_Increment => Alloc.Orig_Nodes_Increment,
Table_Name => "Orig_Nodes");
+ ----------------------------------------
+ -- Global_Variables for New_Copy_Tree --
+ ----------------------------------------
+
+ -- These global variables are used by New_Copy_Tree. See description
+ -- of the body of this subprogram for details. Global variables can be
+ -- safely used by New_Copy_Tree, since there is no case of a recursive
+ -- call from the processing inside New_Copy_Tree.
+
+ NCT_Hash_Threshhold : constant := 20;
+ -- If there are more than this number of pairs of entries in the
+ -- map, then Hash_Tables_Used will be set, and the hash tables will
+ -- be initialized and used for the searches.
+
+ NCT_Hash_Tables_Used : Boolean := False;
+ -- Set to True if hash tables are in use
+
+ NCT_Table_Entries : Nat;
+ -- Count entries in table to see if threshhold is reached
+
+ NCT_Hash_Table_Setup : Boolean := False;
+ -- Set to True if hash table contains data. We set this True if we
+ -- setup the hash table with data, and leave it set permanently
+ -- from then on, this is a signal that second and subsequent users
+ -- of the hash table must clear the old entries before reuse.
+
+ subtype NCT_Header_Num is Int range 0 .. 511;
+ -- Defines range of headers in hash tables (512 headers)
+
-----------------------
-- Local Subprograms --
-----------------------
-- (because setting up a hash table for only a few entries takes
-- more time than it saves.
- -- Global variables are safe for this purpose, since there is no case
- -- of a recursive call from the processing inside New_Copy_Tree.
-
- NCT_Hash_Threshhold : constant := 20;
- -- If there are more than this number of pairs of entries in the
- -- map, then Hash_Tables_Used will be set, and the hash tables will
- -- be initialized and used for the searches.
-
- NCT_Hash_Tables_Used : Boolean := False;
- -- Set to True if hash tables are in use
-
- NCT_Table_Entries : Nat;
- -- Count entries in table to see if threshhold is reached
-
- NCT_Hash_Table_Setup : Boolean := False;
- -- Set to True if hash table contains data. We set this True if we
- -- setup the hash table with data, and leave it set permanently
- -- from then on, this is a signal that second and subsequent users
- -- of the hash table must clear the old entries before reuse.
-
- subtype NCT_Header_Num is Int range 0 .. 511;
- -- Defines range of headers in hash tables (512 headers)
-
function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
-- Hash function used for hash operations
-- --
-- B o d y --
-- --
--- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2003 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 Flush is
+ Last : Natural;
begin
if Lines (Current).Length /= 0 then
Osint.Fail ("INTERNAL ERROR: flushing before end of line: """ &
for J in 1 .. Current - 1 loop
if not Lines (J).Suppressed then
- Text_IO.Put_Line (File, Lines (J).Value (1 .. Lines (J).Length));
+ Last := Lines (J).Length;
+
+ -- The last character of a line cannot be a back slash ('\'),
+ -- otherwise make has a problem. The only real place were it
+ -- should happen is for directory names on Windows, and then
+ -- this terminal back slash is not needed.
+
+ if Last > 0 and then Lines (J).Value (Last) = '\' then
+ Last := Last - 1;
+ end if;
+
+ Text_IO.Put_Line (File, Lines (J).Value (1 .. Last));
end if;
end loop;
with Erroutc; use Erroutc;
with Err_Vars; use Err_Vars;
-with Gnatvsn;
+with Gnatvsn; use Gnatvsn;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
Put ("src.list_file:=" &
"$(strip $(shell gprcmd to_absolute $(");
Put (Project_Name);
- Put (".base_dir) $(");
+ Put (".base_dir) '$(");
Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put_Line (")))");
+ Put_Line (")'))");
if In_Case then
if Source_List_File_Declaration = False then
Put (".obj_dir:=" &
"$(strip $(shell gprcmd to_absolute $(");
Put (Project_Name);
- Put (".base_dir) $(");
+ Put (".base_dir) '$(");
Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put_Line (")))");
+ Put_Line (")'))");
elsif Item_Name = Snames.Name_Exec_Dir then
Put ("EXEC_DIR:=" &
"$(strip $(shell gprcmd to_absolute $(");
Put (Project_Name);
- Put (".base_dir) $(");
+ Put (".base_dir) '$(");
Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put_Line (")))");
+ Put_Line (")'))");
elsif Item_Name = Snames.Name_Main then
-- types, i.e. record types (Java classes) that hold pointers to each
-- other. If such a type is an access type, it has no explicit freeze
-- node, so that the back-end does not attempt to elaborate it.
+-- Currently this flag is also used to implement Ada0Y (AI-50217).
+-- It will be renamed to From_Limited_With after removal of the current
+-- GNAT with_type clause???
-- Full_View (Node11)
-- Present in all type and subtype entities and in deferred constants.
-- Present in non-generic package entities that are not instances.
-- The elements of this list are the shadow entities created for the
-- types and local packages that are declared in a package that appears
--- in a limited_with clause.
+-- in a limited_with clause (Ada0Y: AI-50217)
-- Lit_Indexes (Node15)
-- Present in enumeration types and subtypes. Non-empty only for the
-- is other than a power of 2.
-- Non_Limited_View (Node17)
--- Present in incomplete types that are the shadow entities
--- created when analyzing a limited_with_clause. Points to the
--- definining entity in the original declaration.
+-- Present in incomplete types that are the shadow entities created
+-- when analyzing a limited_with_clause (Ada0Y: AI-50217). Points to
+-- the defining entity in the original declaration.
-- Nonzero_Is_True (Flag162) [base type only]
-- Present in enumeration types. True if any non-zero value is to be
Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last;
end if;
- -- Set all (???) the error nodes to Empty:
+ -- Set the error nodes to Empty to avoid uninitialized variable
+ -- references for saves/restores/moves.
Error_Msg_Node_1 := Empty;
Error_Msg_Node_2 := Empty;
-
end Initialize;
-----------------
-- sorted order.
function Has_Default_Init_Comps (N : Node_Id) return Boolean;
- -- N is an aggregate (record or array). Checks the presence of
- -- default initialization (<>) in any component.
+ -- N is an aggregate (record or array). Checks the presence of default
+ -- initialization (<>) in any component (Ada0Y: AI-287)
------------------------------------------------------
-- Local subprograms for Record Aggregate Expansion --
Selector_Name => Make_Identifier (Loc, Name_uController));
Set_Assignment_OK (Ref);
- -- Give support to default initialization of limited types and
- -- components
+ -- Ada0Y (AI-287): Give support to default initialization of limited
+ -- types and components
if (Nkind (Target) = N_Identifier
and then Is_Limited_Type (Etype (Target)))
Check_Ancestor_Discriminants (Entity (A));
end if;
- -- If the ancestor part is a limited type, a recursive call
- -- expands the ancestor.
+ -- Ada0Y (AI-287): If the ancestor part is a limited type, a
+ -- recursive call expands the ancestor.
elsif Is_Limited_Type (Etype (A)) then
Ancestor_Is_Expression := True;
then
Convert_To_Assignments (N, Typ);
+ -- Ada0Y (AI-287): In case of default initialized components we convert
+ -- the aggregate into assignments.
+
elsif Has_Default_Init_Comps (N) then
Convert_To_Assignments (N, Typ);
if Nkind (Actual) = N_Type_Conversion then
V_Typ := Etype (Expression (Actual));
- Var := Make_Var (Expression (Actual));
+
+ -- If the formal is an (in-)out parameter, capture the name
+ -- of the variable in order to build the post-call assignment.
+ -- The variable itself may have been expanded, for example if
+ -- it is a complex bit-packed array, so we need to recover the
+ -- original to ensure that we have the proper target for the
+ -- assignment. Examine the slocs of the two nodes to determine
+ -- whether the rewriting is an expansion, or a substitution done
+ -- on an inlined body, in which case it must be respected.
+
+ declare
+ Orig : constant Node_Id := Original_Node (Expression (Actual));
+ begin
+ if Orig /= Expression (Actual)
+ and then Sloc (Orig) = Sloc (Expression (Actual))
+ then
+ Var := Make_Var (Orig);
+ else
+ Var := Make_Var (Expression (Actual));
+ end if;
+ end;
+
Crep := not Same_Representation
(Etype (Formal), Etype (Expression (Actual)));
else
function Is_Absolute_Path (Name : String) return Boolean;
-- Returns True if Name is an absolute path name, i.e. it designates
- -- a directory absolutely, rather than relative to another directory.
+ -- a file or a directory absolutely, rather than relative to another
+ -- directory.
function Is_Regular_File (Name : String) return Boolean;
-- Determines if the given string, Name, is the name of an existing
- -- regular file. Returns True if so, False otherwise.
+ -- regular file. Returns True if so, False otherwise. Name may be an
+ -- absolute path name or a relative path name, including a simple file
+ -- name. If it is a relative path name, it is relative to the current
+ -- working directory.
function Is_Directory (Name : String) return Boolean;
-- Determines if the given string, Name, is the name of a directory.
- -- Returns True if so, False otherwise.
+ -- Returns True if so, False otherwise. Name may be an absolute path
+ -- name or a relative path name, including a simple file name. If it is
+ -- a relative path name, it is relative to the current working directory.
function Is_Readable_File (Name : String) return Boolean;
-- Determines if the given string, Name, is the name of an existing
procedure Usage is
begin
New_Line;
- Put ("GNATMEM Pro ");
+ Put ("GNATMEM ");
Put (Gnat_Version_String);
Put_Line (" Copyright 1997-2003 Free Software Foundation, Inc.");
New_Line;
-- only on OpenVMS.
-- gnatsym takes as parameters:
--- - the name of the symbol file to create or update
+-- - the name of the symbol file to create
+-- - (optional) the policy to create the symbol file
+-- - (optional) the name of the reference symbol file
-- - the names of one or more object files where the symbols are found
with GNAT.Command_Line; use GNAT.Command_Line;
procedure Gnatsym is
+ Empty_String : aliased String := "";
+ Empty : constant String_Access := Empty_String'Unchecked_Access;
+ -- To initialize variables Reference and Version_String
+
Copyright_Displayed : Boolean := False;
-- A flag to prevent multiple display of the Copyright notice
Success : Boolean := True;
- Force : Boolean := False;
- -- True when -f switcxh is used
+ Symbol_Policy : Policy := Autonomous;
Verbose : Boolean := False;
-- True when -v switch is used
Quiet : Boolean := False;
-- True when -q switch is used
- Symbol_File_Name : String_Access;
+ Symbol_File_Name : String_Access := null;
-- The name of the symbol file
+ Reference_Symbol_File_Name : String_Access := Empty;
+ -- The name of the reference symbol file
+
+ Version_String : String_Access := Empty;
+ -- The version of the library. Used on VMS.
+
package Object_Files is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
procedure Parse_Cmd_Line is
begin
loop
- case GNAT.Command_Line.Getopt ("f q v") is
+ case GNAT.Command_Line.Getopt ("c C q r: s: v V:") is
when ASCII.NUL =>
exit;
- when 'f' =>
- Force := True;
+ when 'c' =>
+ Symbol_Policy := Compliant;
+
+ when 'C' =>
+ Symbol_Policy := Controlled;
when 'q' =>
Quiet := True;
+ when 'r' =>
+ Reference_Symbol_File_Name :=
+ new String'(GNAT.Command_Line.Parameter);
+
+ when 's' =>
+ Symbol_File_Name := new String'(GNAT.Command_Line.Parameter);
+
when 'v' =>
Verbose := True;
+ when 'V' =>
+ Version_String := new String'(GNAT.Command_Line.Parameter);
+
when others =>
Fail ("invalid switch: ", Full_Switch);
end case;
begin
exit when S'Length = 0;
- if Symbol_File_Name = null then
- Symbol_File_Name := S;
-
- else
- Object_Files.Increment_Last;
- Object_Files.Table (Object_Files.Last) := S;
- end if;
+ Object_Files.Increment_Last;
+ Object_Files.Table (Object_Files.Last) := S;
end;
end loop;
exception
procedure Usage is
begin
- Write_Line ("gnatsym [options] sym_file object_file {object_file}");
+ Write_Line ("gnatsym [options] object_file {object_file}");
Write_Eol;
- Write_Line (" -f Force generation of symbol file");
- Write_Line (" -q Quiet mode");
- Write_Line (" -v Verbose mode");
+ Write_Line (" -c Compliant policy");
+ Write_Line (" -C Controlled policy");
+ Write_Line (" -q Quiet mode");
+ Write_Line (" -r<ref> Reference symbol file name");
+ Write_Line (" -s<sym> Symbol file name");
+ Write_Line (" -v Verbose mode");
+ Write_Line (" -V<ver> Version");
+ Write_Eol;
+ Write_Line ("Specifying a symbol file with -s<sym> is compulsory");
Write_Eol;
end Usage;
-- If there is no symbol file or no object files on the command line,
-- display the usage and exit with an error status.
- if Object_Files.Last = 0 then
+ if Symbol_File_Name = null or else Object_Files.Last = 0 then
Usage;
OS_Exit (1);
Write_Line ("""");
end if;
- -- Initialize the symbol file
+ -- Initialize the symbol file and, if specified, read the reference
+ -- file.
- Symbols.Initialize (Symbol_File_Name.all, Force, Quiet, Success);
+ Symbols.Initialize
+ (Symbol_File => Symbol_File_Name.all,
+ Reference => Reference_Symbol_File_Name.all,
+ Symbol_Policy => Symbol_Policy,
+ Quiet => Quiet,
+ Version => Version_String.all,
+ Success => Success);
-- Process the object files in order. Stop as soon as there is
-- something wrong.
Finalize (Quiet, Success);
end if;
+ -- Fail if there was anything wrong
+
if not Success then
Fail ("unable to build symbol file");
end if;
Version : constant String :=
"GPRCMD " & Gnatvsn.Gnat_Version_String &
- " Copyright 2002-2003, Ada Core Technologies Inc.";
+ " Copyright 2002-2003, Free Software Fundation, Inc.";
procedure Cat (File : String);
-- Print the contents of file on standard output.
-- legitimately occurs (e.g. two package bodies that contain
-- inlined subprogram referenced by the other).
- -- We also ignore limited_with clauses, because their purpose is
- -- precisely to create legal circular structures.
+ -- Ada0Y (AI-50217): We also ignore limited_with clauses, because
+ -- their purpose is precisely to create legal circular structures.
if Loading (Unum)
and then (Is_Spec_Name (Units.Table (Unum).Unit_Name)
Item := First (Context_Items (Cunit));
while Present (Item) loop
- -- limited_with_clauses do not create dependencies.
+ -- Ada0Y (AI-50217): limited with_clauses do not create
+ -- dependencies
if Nkind (Item) = N_With_Clause
and then not (Limited_Present (Item))
Interfaces => Arguments (1 .. Argument_Number),
Lib_Filename => Lib_Filename.all,
Lib_Dir => Lib_Dirpath.all,
+ Symbol_Data => Data.Symbol_Data,
Driver_Name => Driver_Name,
Lib_Address => DLL_Address.all,
Lib_Version => Lib_Version.all,
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
pragma Unreferenced (Interfaces);
pragma Unreferenced (Lib_Filename);
pragma Unreferenced (Lib_Dir);
+ pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Driver_Name);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Lib_Version);
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
-- Afiles is the list of ALI files for the Ada object files.
-- Options is a list of options to be passed to the tool (gcc or other)
-- that effectively builds the dynamic library.
+ --
-- Interfaces is the list of ALI files for the interfaces of a SAL.
-- It is empty if the library is not a SAL.
+ --
-- Lib_Filename is the name of the library, without any prefix or
-- extension. For example, on Unix, if Lib_Filename is "toto", the name of
-- the library file will be "libtoto.so".
+ --
-- Lib_Dir is the directory path where the library will be located.
+ --
-- Lib_Address is the base address of the library for a non relocatable
-- library, given as an hexadecimal string.
- -- For OSes that support symbolic links, Lib_Version, if non null, is
- -- the actual file name of the library. For example on Unix,
- -- if Lib_Filename is "toto" and Lib_Version is "libtoto.so.2.1",
- -- "libtoto.so" will be a symbolic link to "libtoto.so.2.1" which will
- -- be the actual library file.
+ --
+ -- For OSes that support symbolic links, Lib_Version, if non null,
+ -- is the actual file name of the library. For example on Unix, if
+ -- Lib_Filename is "toto" and Lib_Version is "libtoto.so.2.1",
+ -- "libtoto.so" will be a symbolic link to "libtoto.so.2.1" which
+ -- will be the actual library file.
+ --
-- Relocatable indicates if the library should be relocatable or not,
-- for those OSes that actually support non relocatable dynamic libraries.
-- Relocatable indicates that automatic elaboration/finalization must be
-- indicated to the linker, if possible.
+ --
+ -- Symbol_Data is used for some patforms, including VMS, to generate
+ -- the symbols to be exported by the library.
+ --
-- Note: Depending on the OS, some of the parameters may not be taken
-- into account. For example, on Linux, Foreign, Afiles Lib_Address and
-- Relocatable are ignored.
-- Processing for WITH clause
- -- First check for LIMITED WITH
+ -- Ada0Y (AI-50217): First check for LIMITED WITH
if Token = Tok_Limited then
Has_Limited := True;
-- Error recovery: can raise Error_Resync
+ -- Note: POSITIONAL_ARRAY_AGGREGATE rule has been extended to give support
+ -- to Ada0Y limited aggregates (AI-287)
+
function P_Aggregate_Or_Paren_Expr return Node_Id is
Aggregate_Node : Node_Id;
Expr_List : List_Id;
-- Error recovery: can raise Error_Resync
+ -- Note: RECORD_COMPONENT_ASSOCIATION and ARRAY_COMPONENT_ASSOCIATION
+ -- rules have been extended to give support to Ada0Y limited
+ -- aggregates (AI-287)
+
function P_Record_Or_Array_Component_Association return Node_Id is
Assoc_Node : Node_Id;
"LVlibrary_options#" &
"SVlibrary_src_dir#" &
"SVlibrary_gcc#" &
+ "SVlibrary_symbol_file#" &
+ "SVlibrary_symbol_policy#" &
+ "SVlibrary_reference_symbol_file#" &
"LVmain#" &
"LVlanguages#" &
"SVmain_language#" &
(Snames.Name_Library_Src_Dir,
Data.Decl.Attributes);
- Auto_Init_Supported
- : constant Boolean :=
- MLib.Tgt.
- Standalone_Library_Auto_Init_Is_Supported;
+ Lib_Symbol_File : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Symbol_File,
+ Data.Decl.Attributes);
+
+ Lib_Symbol_Policy : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Symbol_Policy,
+ Data.Decl.Attributes);
+
+ Lib_Ref_Symbol_File : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Reference_Symbol_File,
+ Data.Decl.Attributes);
+
+ Auto_Init_Supported : constant Boolean :=
+ MLib.Tgt.
+ Standalone_Library_Auto_Init_Is_Supported;
+
+ OK : Boolean := True;
begin
pragma Assert (Lib_Interfaces.Kind = List);
- -- It is a library project file if attribute Library_Interface
- -- is defined.
+ -- It is a stand-alone library project file if attribute
+ -- Library_Interface is defined.
if not Lib_Interfaces.Default then
declare
Lib_Auto_Init.Location);
end if;
end if;
+ end;
- if Lib_Src_Dir.Value /= Empty_String then
- declare
- Dir_Id : constant Name_Id := Lib_Src_Dir.Value;
+ -- 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.
- begin
- Locate_Directory
- (Dir_Id, Data.Display_Directory,
- Data.Library_Src_Dir,
- Data.Display_Library_Src_Dir);
+ if Lib_Src_Dir.Value /= Empty_String then
+ declare
+ Dir_Id : constant Name_Id := Lib_Src_Dir.Value;
- -- Comment needed here ???
+ begin
+ Locate_Directory
+ (Dir_Id, Data.Display_Directory,
+ Data.Library_Src_Dir,
+ Data.Display_Library_Src_Dir);
- if Data.Library_Src_Dir = No_Name then
+ -- If directory does not exist, report an error
- -- Get the absolute name of the library directory
- -- that does not exist, to report an error.
+ if Data.Library_Src_Dir = No_Name then
- declare
- Dir_Name : constant String :=
- Get_Name_String (Dir_Id);
- begin
- if Is_Absolute_Path (Dir_Name) then
- Err_Vars.Error_Msg_Name_1 := Dir_Id;
+ -- Get the absolute name of the library directory
+ -- that does not exist, to report an error.
- else
- Get_Name_String (Data.Directory);
+ declare
+ Dir_Name : constant String :=
+ Get_Name_String (Dir_Id);
- if Name_Buffer (Name_Len) /=
- Directory_Separator
- then
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) :=
- Directory_Separator;
- end if;
+ begin
+ if Is_Absolute_Path (Dir_Name) then
+ Err_Vars.Error_Msg_Name_1 := Dir_Id;
- 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;
+ else
+ Get_Name_String (Data.Directory);
- -- Report the error
+ if Name_Buffer (Name_Len) /=
+ Directory_Separator
+ then
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) :=
+ Directory_Separator;
+ end if;
- Error_Msg
- (Project,
- "Directory { does not exist",
- Lib_Src_Dir.Location);
- end;
+ 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;
- -- And comment needed here ???
+ -- Report the error
- elsif Data.Library_Src_Dir = Data.Object_Directory then
Error_Msg
(Project,
- "directory to copy interfaces cannot be " &
- "the object directory",
+ "Directory { does not exist",
Lib_Src_Dir.Location);
- Data.Library_Src_Dir := No_Name;
+ end;
- -- And comment needed here ???
+ -- Report an error if it is the same as the object
+ -- directory.
- else
- declare
- Src_Dirs : String_List_Id := Data.Source_Dirs;
- Src_Dir : String_Element;
- begin
- while Src_Dirs /= Nil_String loop
- Src_Dir := String_Elements.Table (Src_Dirs);
- Src_Dirs := Src_Dir.Next;
-
- 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;
+ 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;
- if Data.Library_Src_Dir /= No_Name
- and then Current_Verbosity = High
+ -- Check if it is the same as one of the source
+ -- directories.
+
+ else
+ declare
+ Src_Dirs : String_List_Id := Data.Source_Dirs;
+ Src_Dir : String_Element;
+
+ begin
+ while Src_Dirs /= Nil_String loop
+ Src_Dir := String_Elements.Table (Src_Dirs);
+ Src_Dirs := Src_Dir.Next;
+
+ -- Report an error if it is one of the
+ -- source directories.
+
+ 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;
+
+ 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;
+
+ if not Lib_Symbol_File.Default then
+ Data.Symbol_Data.Symbol_File := Lib_Symbol_File.Value;
+
+ Get_Name_String (Lib_Symbol_File.Value);
+
+ if Name_Len = 0 then
+ Error_Msg
+ (Project,
+ "symbol file name cannot be an empty string",
+ Lib_Symbol_File.Location);
+
+ else
+ OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
+
+ if OK then
+ for J in 1 .. Name_Len loop
+ if Name_Buffer (J) = '/'
+ or else Name_Buffer (J) = Directory_Separator
then
- Write_Str ("Directory to copy interfaces =""");
- Write_Str (Get_Name_String (Data.Library_Dir));
- Write_Line ("""");
+ OK := False;
+ exit;
end if;
- end if;
- end;
+ end loop;
+ end if;
+
+ 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;
+ end if;
+
+ if not Lib_Symbol_Policy.Default then
+ declare
+ Value : constant String :=
+ To_Lower
+ (Get_Name_String (Lib_Symbol_Policy.Value));
+
+ begin
+ 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
+ Error_Msg
+ (Project,
+ "illegal value for Library_Symbol_Policy",
+ Lib_Symbol_Policy.Location);
+ end if;
+ end;
+ end if;
+
+ 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;
+
+ else
+ Data.Symbol_Data.Reference := Lib_Ref_Symbol_File.Value;
+
+ Get_Name_String (Lib_Symbol_File.Value);
+
+ if Name_Len = 0 then
+ Error_Msg
+ (Project,
+ "reference symbol file name cannot be an empty string",
+ Lib_Symbol_File.Location);
+
+ else
+ OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
+
+ 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 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 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;
Standalone_Library => False,
Lib_Interface_ALIs => Nil_String,
Lib_Auto_Init => False,
+ Symbol_Data => No_Symbols,
Sources_Present => True,
Sources => Nil_String,
Source_Dirs => Nil_String,
type Lib_Kind is (Static, Dynamic, Relocatable);
+ type Policy is (Autonomous, Compliant, Controlled);
+ -- See explaination about this type in package Symbol
+
+ type Symbol_Record is record
+ Symbol_File : Name_Id := No_Name;
+ Reference : Name_Id := No_Name;
+ Symbol_Policy : Policy := Autonomous;
+ end record;
+ -- Type to keep the symbol data to be used when building a shared library
+
+ No_Symbols : Symbol_Record :=
+ (Symbol_File => No_Name,
+ Reference => No_Name,
+ Symbol_Policy => Autonomous);
+
function Empty_String return Name_Id;
type Project_Id is new Nat;
-- For non static Standalone Library Project Files, indicate if
-- the library initialisation should be automatic.
+ Symbol_Data : Symbol_Record := No_Symbols;
+ -- Symbol file name, reference symbol file name, symbol policy
+
Sources_Present : Boolean := True;
-- A flag that indicates if there are sources in this project file.
-- There are no sources if 1) Source_Dirs is specified as an
for J in RE_Id loop
RE_Table (J) := Empty;
end loop;
+
+ RTE_Is_Available := False;
end Initialize;
------------
-- --
------------------------------------------------------------------------------
--- This is the VxWorks version of this package
-
-pragma Restrictions (No_Tasking);
--- The VxWorks version of this package is intended only for programs
--- which do not use Ada tasking. This restriction ensures that this
--- will be checked by the binder.
-
-with System.Secondary_Stack;
+-- This is a dummy version of this package.
with Unchecked_Conversion;
package body System.Threads is
- package SSS renames System.Secondary_Stack;
-
- Current_ATSD : aliased System.Address := System.Null_Address;
- pragma Export (C, Current_ATSD, "__gnat_current_atsd");
-
- function From_Address is
- new Unchecked_Conversion (Address, ATSD_Access);
-
- procedure Init_Float;
- pragma Import (C, Init_Float, "__gnat_init_float");
-
- procedure Install_Handler;
- pragma Import (C, Install_Handler, "__gnat_install_handler");
-
-----------------------
-- Get_Current_Excep --
-----------------------
function Get_Current_Excep return EOA is
- CTSD : ATSD_Access := From_Address (Current_ATSD);
begin
- pragma Assert (Current_ATSD /= System.Null_Address);
- return CTSD.Current_Excep'Access;
+ return null;
end Get_Current_Excep;
------------------------
------------------------
function Get_Jmpbuf_Address return Address is
- CTSD : ATSD_Access := From_Address (Current_ATSD);
begin
- pragma Assert (Current_ATSD /= System.Null_Address);
- return CTSD.Jmpbuf_Address;
+ return Null_Address;
end Get_Jmpbuf_Address;
------------------------
------------------------
function Get_Sec_Stack_Addr return Address is
- CTSD : ATSD_Access := From_Address (Current_ATSD);
begin
- pragma Assert (Current_ATSD /= System.Null_Address);
- return CTSD.Sec_Stack_Addr;
+ return Null_Address;
end Get_Sec_Stack_Addr;
------------------------
------------------------
procedure Set_Jmpbuf_Address (Addr : Address) is
- CTSD : ATSD_Access := From_Address (Current_ATSD);
+ pragma Unreferenced (Addr);
begin
- pragma Assert (Current_ATSD /= System.Null_Address);
- CTSD.Jmpbuf_Address := Addr;
+ null;
end Set_Jmpbuf_Address;
------------------------
------------------------
procedure Set_Sec_Stack_Addr (Addr : Address) is
- CTSD : ATSD_Access := From_Address (Current_ATSD);
+ pragma Unreferenced (Addr);
begin
- pragma Assert (Current_ATSD /= System.Null_Address);
- CTSD.Sec_Stack_Addr := Addr;
+ null;
end Set_Sec_Stack_Addr;
-----------------------
Sec_Stack_Size : Natural;
Process_ATSD_Address : System.Address)
is
- -- Current_ATSD must already be a taskVar of taskIdSelf.
- -- No assertion because taskVarGet is not available on VxWorks/CERT
-
- TSD : ATSD_Access := From_Address (Process_ATSD_Address);
-
+ pragma Unreferenced (Sec_Stack_Address);
+ pragma Unreferenced (Sec_Stack_Size);
+ pragma Unreferenced (Process_ATSD_Address);
begin
- TSD.Sec_Stack_Addr := Sec_Stack_Address;
- SSS.SS_Init (TSD.Sec_Stack_Addr, Sec_Stack_Size);
- Current_ATSD := Process_ATSD_Address;
-
- Install_Handler;
- Init_Float;
+ null;
end Thread_Body_Enter;
----------------------------------
is
pragma Unreferenced (EO);
begin
- -- No action for this target
-
null;
end Thread_Body_Exceptional_Exit;
procedure Thread_Body_Leave is
begin
- -- No action for this target
-
null;
end Thread_Body_Leave;
-begin
- System.Threads.Initialization.Init_RTS;
end System.Threads;
Error_Msg_N ("aggregate type cannot have limited component", N);
Explain_Limited_Type (Typ, N);
+ -- Ada0Y (AI-287): Limited aggregates allowed
+
elsif Is_Limited_Type (Typ)
and not Extensions_Allowed
then
Error_Msg_N ("type of extension aggregate must be tagged", N);
return;
- elsif Is_Limited_Type (Typ)
- and not Extensions_Allowed
- then
- Error_Msg_N ("aggregate type cannot be limited", N);
- Explain_Limited_Type (Typ, N);
- return;
+ elsif Is_Limited_Type (Typ) then
+
+ -- Ada0Y (AI-287): Limited aggregates are allowed
+
+ if Extensions_Allowed then
+ null;
+ else
+ Error_Msg_N ("aggregate type cannot be limited", N);
+ Explain_Limited_Type (Typ, N);
+ return;
+ end if;
elsif Is_Class_Wide_Type (Typ) then
Error_Msg_N ("aggregate cannot be of a class-wide type", N);
Mbox_Present : Boolean := False;
Others_Mbox : Boolean := False;
- -- Variables used in case of default initialization to provide a
- -- functionality similar to Others_Etype. Mbox_Present indicates
- -- that the component takes its default initialization; Others_Mbox
- -- indicates that at least one component takes its default initiali-
- -- zation. Similar to Others_Etype, they are also updated as a side
- -- effect of function Get_Value.
+ -- Ada0Y (AI-287): Variables used in case of default initialization to
+ -- provide a functionality similar to Others_Etype. Mbox_Present
+ -- indicates that the component takes its default initialization;
+ -- Others_Mbox indicates that at least one component takes its default
+ -- initialization. Similar to Others_Etype, they are also updated as a
+ -- side effect of function Get_Value.
procedure Add_Association
(Component : Entity_Id;
and then Comes_From_Source (Compon)
and then not In_Instance_Body
then
+ -- Ada0Y (AI-287): Limited aggregates are allowed
if Extensions_Allowed
and then Present (Expression (Assoc))
-- indispensable otherwise, because each one must be
-- expanded individually to preserve side-effects.
+ -- Ada0Y (AI-287): In case of default initialization of
+ -- components, we duplicate the corresponding default
+ -- expression (from the record type declaration).
+
if Box_Present (Assoc) then
Others_Mbox := True;
Mbox_Present := True;
if Mbox_Present and then Is_Limited_Type (Etype (Component)) then
- -- In case of default initialization of a limited component we
- -- pass the limited component to the expander. The expander will
- -- generate calls to the corresponding initialization subprograms.
+ -- Ada0Y (AI-287): In case of default initialization of a limited
+ -- component we pass the limited component to the expander. The
+ -- expander will generate calls to the corresponding initiali-
+ -- zation subprograms.
Add_Association
(Component => Component,
Typech := Empty;
if Nkind (Selectr) = N_Others_Choice then
+
+ -- Ada0Y (AI-287): others choice may have expression or mbox
+
if No (Others_Etype)
and then not Others_Mbox
then
if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
-- If we are within an instance, the attribute must be legal
- -- because it was valid in the generic unit.
+ -- because it was valid in the generic unit. Ditto if this is
+ -- an inlining of a function declared in an instance.
- if In_Instance then
+ if In_Instance
+ or else In_Inlined_Body
+ then
return;
-- For sure OK if we have a real private type itself, but must
return;
end if;
- -- Process explicit with_clauses that are not limited.
+ -- Ada0Y (AI-50217): Process explicit with_clauses that are not limited
declare
Item : Node_Id;
-- in a limited_with clause. If the package was not previously analyzed
-- then it also performs a basic decoration of the real entities; this
-- is required to do not pass non-decorated entities to the back-end.
+ -- Implements Ada0Y (AI-50217).
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
-- Check whether the source for the body of a compilation unit must
-- and not in an inner frame.
procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id);
- -- if a child unit appears in a limited_with clause, there are implicit
+ -- If a child unit appears in a limited_with clause, there are implicit
-- limited_with clauses on all parents that are not already visible
-- through a regular with clause. This procedure creates the implicit
-- limited with_clauses for the parents and loads the corresponding units.
-- The shadow entities are created when the inserted clause is analyzed.
+ -- Implements Ada0Y (AI-50217).
procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id);
-- When a child unit appears in a context clause, the implicit withs on
procedure Install_Limited_Context_Clauses (N : Node_Id);
-- Subsidiary to Install_Context. Process only limited with_clauses
- -- for current unit.
+ -- for current unit. Implements Ada0Y (AI-50217).
procedure Install_Limited_Withed_Unit (N : Node_Id);
-- Place shadow entities for a limited_with package in the visibility
- -- structures for the current compilation.
+ -- structures for the current compilation. Implements Ada0Y (AI-50217).
procedure Install_Withed_Unit (With_Clause : Node_Id);
-- If the unit is not a child unit, make unit immediately visible.
procedure Remove_Limited_With_Clause (N : Node_Id);
-- Remove from visibility the shadow entities introduced for a package
- -- mentioned in a limited_with clause.
+ -- mentioned in a limited_with clause. Implements Ada0Y (AI-50217).
procedure Remove_Parents (Lib_Unit : Node_Id);
-- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
begin
Item := First (Context_Items (N));
while Present (Item) loop
+
+ -- Ada0Y (AI-50217): Do not consider limited-withed units
+
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
and then not Limited_Present (Item)
-- Loop through context items. This is done is three passes:
-- a) The first pass analyze non-limited with-clauses.
-- b) The second pass add implicit limited_with clauses for
- -- the parents of child units.
- -- c) The third pass analyzes limited_with clauses.
+ -- the parents of child units (Ada0Y: AI-50217)
+ -- c) The third pass analyzes limited_with clauses (Ada0Y: AI-50217)
Item := First (Context_Items (N));
while Present (Item) loop
begin
if Limited_Present (N) then
-
- -- Build visibility structures but do not analyze unit
+ -- Ada0Y (AI-50217): Build visibility structures but do not
+ -- analyze unit
Build_Limited_Views (N);
return;
Unit_Name : Entity_Id;
begin
- -- We remove the context clauses in two phases: limited-views first
- -- and regular-views later (to maintain the stack model).
+ -- Ada0Y (AI-50217): We remove the context clauses in two phases:
+ -- limited-views first and regular-views later (to maintain the
+ -- stack model).
-- First Phase: Remove limited_with context clauses
Defining_Identifier (Analyzed_Formal));
if No (Match) then
+ Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE
("missing actual&",
Instantiation_Node, Defining_Identifier (Formal));
Defining_Identifier (Original_Node (Analyzed_Formal)));
if No (Match) then
+ Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE
("missing actual&",
Instantiation_Node, Defining_Identifier (Formal));
end loop;
if Num_Actuals > Num_Matched then
+ Error_Msg_Sloc := Sloc (Gen_Unit);
+
if Present (Selector_Name (Actual)) then
Error_Msg_NE
("unmatched actual&",
elsif Ekind (Gen_Unit) /= E_Generic_Package then
+ -- Ada0Y (AI-50217): Instance can not be used in limited with_clause
+
if From_With_Type (Gen_Unit) then
Error_Msg_N
("cannot instantiate a limited withed package", Gen_Id);
end if;
else
+ Error_Msg_Sloc := Sloc (Scope (Analyzed_S));
Error_Msg_NE
("missing actual&", Instantiation_Node, Formal_Sub);
Error_Msg_NE
Subt_Decl : Node_Id := Empty;
begin
+ -- Sloc for error message on missing actual.
+ Error_Msg_Sloc := Sloc (Scope (Defining_Identifier (Analyzed_Formal)));
+
if Get_Instance_Of (Formal_Id) /= Formal_Id then
Error_Msg_N ("duplicate instantiation of generic parameter", Actual);
end if;
-- if the designated type is.
Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
+
+ -- Ada0Y (AI-50217): Propagate the attribute that indicates that the
+ -- designated type comes from the limited view (for back-end purposes).
+
Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
-- The context is either a subprogram declaration or an access
-- access type is also imported, and therefore restricted in its use.
-- The access type may already be imported, so keep setting otherwise.
- -- If the non-limited view of the designated type is available, use
- -- it as the designated type of the access type, so that the back-end
- -- gets a usable entity.
+ -- Ada0Y (AI-50217): If the non-limited view of the designated type is
+ -- available, use it as the designated type of the access type, so that
+ -- the back-end gets a usable entity.
if From_With_Type (Desig) then
Set_From_With_Type (T);
begin
Prev := Find_Type_Name (N);
- -- The full view, if present, now points to the current type. If the
- -- type was previously decorated when imported through a LIMITED WITH
- -- clause, it appears as incomplete but has no full view.
+ -- The full view, if present, now points to the current type
+
+ -- Ada0Y (AI-50217): If the type was previously decorated when imported
+ -- through a LIMITED WITH clause, it appears as incomplete but has no
+ -- full view.
if Ekind (Prev) = E_Incomplete_Type
and then Present (Full_View (Prev))
or else Is_Limited_Composite (T))
and then not In_Instance
then
- -- Relax the strictness of the front-end in case of limited
- -- aggregates and extension aggregates.
+ -- Ada0Y (AI-287): Relax the strictness of the front-end in case of
+ -- limited aggregates and extension aggregates.
if Extensions_Allowed
and then (Nkind (Exp) = N_Aggregate
and then Comes_From_Source (N)
and then not In_Instance_Body
then
+ -- Ada0Y (AI-287): Do not post an error if the expression corres-
+ -- ponds to a limited aggregate. Limited aggregates are checked in
+ -- sem_aggr in a per-component manner (cf. Get_Value subprogram).
+
if Extensions_Allowed
and then Nkind (Expression (E)) = N_Aggregate
then
Actual := First_Actual (N);
while Present (Actual) loop
+ -- Ada0Y (AI-50217): Post an error in case of premature usage of
+ -- an entity from the limited view.
+
if not Analyzed (Etype (Actual))
and then From_With_Type (Etype (Actual))
then
and then Ekind (Root_Type (Formal_Type)) =
E_Incomplete_Type)
then
-
- -- Incomplete tagged types that are made visible through
- -- a limited with_clause are valid formal types.
+ -- Ada0Y (AI-50217): Incomplete tagged types that are made
+ -- visible through a limited with_clause are valid formal
+ -- types.
if From_With_Type (Formal_Type)
and then Is_Tagged_Type (Formal_Type)
Error_Msg_N
("expect package name in renaming", Name (N));
+ -- Ada0Y (AI-50217): Limited withed packages can not be renamed
+
elsif Ekind (Old_P) = E_Package
and then From_With_Type (Old_P)
then
Set_Chars (Selector, Chars (Id));
end if;
+ -- Ada0Y (AI-50217): Check usage of entities in limited withed units
+
if Ekind (P_Name) = E_Package
and then From_With_Type (P_Name)
then
Set_In_Use (P);
+ -- Ada0Y (AI-50217): Check restriction.
+
if From_With_Type (P) then
Error_Msg_N ("limited withed package cannot appear in use clause", N);
end if;
then
return True;
+ -- Ada0Y (AI-50217): Additional branches to make the shadow entity
+ -- compatible with its real entity.
+
elsif From_With_Type (T1) then
-- If the expected type is the non-limited view of a type, the
begin
if Ekind (T) = E_Incomplete_Type then
- -- If the type is available through a limited_with_clause,
- -- verify that its full view has been analyzed.
+ -- Ada0Y (AI-50217): If the type is available through a limited
+ -- with_clause, verify that its full view has been analyzed.
if From_With_Type (T)
and then Present (Non_Limited_View (T))
-- separable by the parser. The choices list may represent either a
-- list of selector names in the record aggregate case, or a list of
-- discrete choices in the array aggregate case or an N_Others_Choice
- -- node (which appears as a singleton list).
+ -- node (which appears as a singleton list). Box_Present gives support
+ -- to Ada0Y (AI-287).
------------------------------------
-- 4.3.1 Commponent Choice List --
-- Unreferenced_In_Spec (Flag7-Sem)
-- No_Entities_Ref_In_Spec (Flag8-Sem)
+ -- Note: Limited_Present and Limited_View_Installed give support to
+ -- Ada0Y (AI-50217).
+
----------------------
-- With_Type clause --
----------------------
"library_kind#" &
"library_name#" &
"library_options#" &
+ "library_reference_symbol_file#" &
"library_src_dir#" &
"library_symbol_file#" &
+ "library_symbol_policy#" &
"library_version#" &
"linker#" &
"local_configuration_pragmas#" &
Name_Library_Kind : constant Name_Id := N + 558;
Name_Library_Name : constant Name_Id := N + 559;
Name_Library_Options : constant Name_Id := N + 560;
- Name_Library_Src_Dir : constant Name_Id := N + 561;
- Name_Library_Symbol_File : constant Name_Id := N + 562;
- Name_Library_Version : constant Name_Id := N + 563;
- Name_Linker : constant Name_Id := N + 564;
- Name_Local_Configuration_Pragmas : constant Name_Id := N + 565;
- Name_Locally_Removed_Files : constant Name_Id := N + 566;
- Name_Naming : constant Name_Id := N + 567;
- Name_Object_Dir : constant Name_Id := N + 568;
- Name_Pretty_Printer : constant Name_Id := N + 569;
- Name_Project : constant Name_Id := N + 570;
- Name_Separate_Suffix : constant Name_Id := N + 571;
- Name_Source_Dirs : constant Name_Id := N + 572;
- Name_Source_Files : constant Name_Id := N + 573;
- Name_Source_List_File : constant Name_Id := N + 574;
- Name_Spec : constant Name_Id := N + 575;
- Name_Spec_Suffix : constant Name_Id := N + 576;
- Name_Specification : constant Name_Id := N + 577;
- Name_Specification_Exceptions : constant Name_Id := N + 578;
- Name_Specification_Suffix : constant Name_Id := N + 579;
- Name_Switches : constant Name_Id := N + 580;
+ Name_Library_Reference_Symbol_File : constant Name_Id := N + 561;
+ Name_Library_Src_Dir : constant Name_Id := N + 562;
+ Name_Library_Symbol_File : constant Name_Id := N + 563;
+ Name_Library_Symbol_Policy : constant Name_Id := N + 564;
+ Name_Library_Version : constant Name_Id := N + 565;
+ Name_Linker : constant Name_Id := N + 566;
+ Name_Local_Configuration_Pragmas : constant Name_Id := N + 567;
+ Name_Locally_Removed_Files : constant Name_Id := N + 568;
+ Name_Naming : constant Name_Id := N + 569;
+ Name_Object_Dir : constant Name_Id := N + 570;
+ Name_Pretty_Printer : constant Name_Id := N + 571;
+ Name_Project : constant Name_Id := N + 572;
+ Name_Separate_Suffix : constant Name_Id := N + 573;
+ Name_Source_Dirs : constant Name_Id := N + 574;
+ Name_Source_Files : constant Name_Id := N + 575;
+ Name_Source_List_File : constant Name_Id := N + 576;
+ Name_Spec : constant Name_Id := N + 577;
+ Name_Spec_Suffix : constant Name_Id := N + 578;
+ Name_Specification : constant Name_Id := N + 579;
+ Name_Specification_Exceptions : constant Name_Id := N + 580;
+ Name_Specification_Suffix : constant Name_Id := N + 581;
+ Name_Switches : constant Name_Id := N + 582;
-- Other miscellaneous names used in front end
- Name_Unaligned_Valid : constant Name_Id := N + 581;
+ Name_Unaligned_Valid : constant Name_Id := N + 583;
-- Mark last defined name for consistency check in Snames body
- Last_Predefined_Name : constant Name_Id := N + 581;
+ Last_Predefined_Name : constant Name_Id := N + 583;
subtype Any_Operator_Name is Name_Id range
First_Operator_Name .. Last_Operator_Name;
Sprint_Bar_List (Choices (Node));
Write_Str (" => ");
+ -- Ada0Y (AI-287): Print the mbox if present
+
if Box_Present (Node) then
Write_Str_With_Col_Check ("<>");
else
else
if First_Name (Node) or else not Dump_Original_Only then
+
+ -- Ada0Y (AI-50217): Print limited with_clauses
+
if Limited_Present (Node) then
Write_Indent_Str ("limited with ");
else
end if;
when N_With_Type_Clause =>
-
Write_Indent_Str ("with type ");
Sprint_Node_Sloc (Name (Node));
----------------
procedure Initialize
- (Symbol_File : String;
- Force : Boolean;
- Quiet : Boolean;
- Success : out Boolean)
+ (Symbol_File : String;
+ Reference : String;
+ Symbol_Policy : Policy;
+ Quiet : Boolean;
+ Version : String;
+ Success : out Boolean)
is
pragma Unreferenced (Symbol_File);
- pragma Unreferenced (Force);
+ pragma Unreferenced (Reference);
+ pragma Unreferenced (Symbol_Policy);
pragma Unreferenced (Quiet);
+ pragma Unreferenced (Version);
begin
Put_Line
("creation of symbol files are not supported on this platform");
package Symbols is
+ type Policy is
+ -- Symbol policy:
+
+ (Autonomous,
+ -- Create a symbol file without considering any reference
+
+ Compliant,
+ -- Either create a symbol file with the same major and minor IDs if
+ -- all symbols are already found in the reference file or with an
+ -- incremented minor ID, if not.
+
+ Controlled);
+ -- Fail if symbols are not the same as those in the reference file
+
type Symbol_Kind is (Data, Proc);
-- To distinguish between the different kinds of symbols
-- The symbol tables
Original_Symbols : Symbol_Table.Instance;
- -- The symbols, if any, found in the original symbol table
+ -- The symbols, if any, found in the reference symbol table
Complete_Symbols : Symbol_Table.Instance;
-- The symbols, if any, found in the objects files
procedure Initialize
- (Symbol_File : String;
- Force : Boolean;
- Quiet : Boolean;
- Success : out Boolean);
+ (Symbol_File : String;
+ Reference : String;
+ Symbol_Policy : Policy;
+ Quiet : Boolean;
+ Version : String;
+ Success : out Boolean);
-- Initialize a symbol file. This procedure must be called before
-- Processing any object file. Depending on the platforms and the
-- circumstances, additional messages may be issued if Quiet is False.
-- Line for -gnatN switch
Write_Switch_Char ("N");
- Write_Line ("Full (frontend) inlining of subprograqms");
+ Write_Line ("Full (frontend) inlining of subprograms");
-- Line for -gnato switch
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2003 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- --
-- Default_Project_File --
--------------------------
- function Default_Project_File
- (Dir_Name : String)
- return String
- is
+ function Default_Project_File (Dir_Name : String) return String is
My_Dir : Dir_Type;
Dir_Ent : File_Name_String;
Last : Natural;
function File_Name
(File : ALI_File;
- Num : Positive)
- return File_Reference
+ Num : Positive) return File_Reference
is
begin
return File.Dep.Table (Num);
-- unit number is optional. It is specified only if the parent type
-- is not defined in the current unit.
+ -- We also have the format for generic instantiations, as in
+ -- 7a5*Uid(3|5I8[4|2]) 2|4r74
+
-- We could also have something like
-- 16I9*I<integer>
-- that indicates that I derives from the predefined type integer.
Ptr := Ptr + 1;
Parse_Number (Ali, Ptr, P_Column);
+ -- Skip the information for generics instantiations
+
+ if Ali (Ptr) = '[' then
+ declare
+ Num_Brackets : Natural := 1;
+ begin
+ while Num_Brackets /= 0 loop
+ Ptr := Ptr + 1;
+ if Ali (Ptr) = '[' then
+ Num_Brackets := Num_Brackets + 1;
+ elsif Ali (Ptr) = ']' then
+ Num_Brackets := Num_Brackets - 1;
+ end if;
+ end loop;
+
+ Ptr := Ptr + 1;
+ end;
+ end if;
+
-- Skip '>', or ')' or '>'
Ptr := Ptr + 1;
if Der_Info or else Type_Tree then
declare
Symbol : constant String :=
- Get_Symbol_Name (P_Eun, P_Line, P_Column);
-
+ Get_Symbol_Name (P_Eun, P_Line, P_Column);
begin
if Symbol /= "???" then
Add_Parent
projects / platform / upstream / linaro-gcc.git / commitdiff