[multiple changes]
2003-11-17 Jerome Guitton <guitton@act-europe.fr> * 5zthrini.adb: Remove the call to Init_RTS at elaboration, as it is already called in System.Threads. * 5ztiitho.adb (Initialize_Task_Hooks): Remove the registration of the environment task, as it has been moved to System.Threads.Initialization. 2003-11-17 Arnaud Charlet <charlet@act-europe.fr> * adaint.c (__gnatlib_install_locks): Only reference __gnat_install_locks on VMS, since other platforms can avoid using --enable-threads=gnat 2003-11-17 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> * ada-tree.h: (TYPE_IS_PACKED_ARRAY_TYPE_P): New macro. * decl.c (gnat_to_gnu_entity, case E_Array_Subtype): Set TYPE_PACKED_ARRAY_TYPE_P. (validate_size): Do not verify size if TYPE_IS_PACKED_ARRAY_TYPE_P. Part of PR ada/12806 * utils.c (float_type_for_precision): Renamed from float_type_for_size. Use GET_MODE_PRECISION instead of GET_MODE_BITSIZE. 2003-11-17 Vincent Celier <celier@gnat.com> * gnatchop.adb (Error_Msg): New Boolean parameter Warning, defaulted to False. Do not set exit status to Failure when Warning is True. (Gnatchop): Make errors "no compilation units found" and "no source files written" warnings only. * make.adb (Gnatmake): When using a project file, set Look_In_Primary_Dir to False. (Configuration_Pragmas_Switch): Check for Global_Configuration_Pragmas and Local_Configuration_Pragmas in the project where they are declared not an extending project which might have inherited them. * osint.adb (Locate_File): If Name is already an absolute path, do not look for a directory. * par-ch10.adb (P_Compilation_Unit): If source contains no token, and -gnats (Check_Syntax) is used, issue only a warning, not an error. * prj.adb (Register_Default_Naming_Scheme): Add new component Project in objects of type Variable_Value. * prj.ads: (Variable_Value): New component Project * prj-nmsc.adb (Ada_Check.Warn_If_Not_Sources): No warning if source is in a project extended by Project. * prj-proc.adb (Add_Attributes): New parameter Project. Set component Project of Variable_Values to this new parameter value. (Expression): Set component Project of Variable_Values. (Process_Declarative_Items): Call Add_Attributes with parameter Project. Set the component Project in array elements. 2003-11-17 Sergey Rybin <rybin@act-europe.fr> * errout.adb: (Initialize): Add initialization for error nodes. * sem_ch12.adb (Initialize): Add missing initializations for Exchanged_Views and Hidden_Entities. 2003-11-17 Ed Schonberg <schonberg@gnat.com> * sem_ch12.adb (Copy_Generic_Node): Preserve entity when copying an already instantiated tree for use in subsequent inlining. (Analyze_Associations, Instantiate_Formal_Subprogram, Instantiate_Object): improve error message for mismatch in instantiations. * sem_ch6.adb (Build_Body_To_Inline): Major cleanup to handle instantiations of subprograms declared in instances. 2003-11-17 Javier Miranda <miranda@gnat.com> * sem_ch4.adb (Analyze_Allocator): Previous modification must be executed only under the Extensions_Allowed flag. 2003-11-17 Robert Dewar <dewar@gnat.com> * a-exexda.adb (Address_Image): Fix documentation to indicate leading zeroes suppressed. (Address_Image): Fix bug of returning 0x instead of 0x0 Minor reformatting (function specs). * einfo.ads: Minor fix for documentation of Is_Bit_Packed_Array (missed case of 33-63) * freeze.adb, sem_ch13.adb: Properly check size of packed bit array * s-thread.adb: Add comments for pragma Restriction * exp_aggr.adb, g-debuti.adb, par-ch4.adb, sem_aggr.adb, sem_ch6.adb, sprint.adb, xref_lib.adb: Minor reformatting 2003-11-17 Ed Falis <falis@gnat.com> * s-thread.adb: Added No_Tasking restriction for this implementation. 2003-11-17 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-17 GNAT Script <nobody@gnat.com> * Make-lang.in: Makefile automatically updated From-SVN: r73672
This commit is contained in:
parent
638dcaa0b0
commit
d05ef0ab60
@ -115,7 +115,6 @@ package body System.Threads.Initialization is
|
||||
|
||||
begin
|
||||
Initialize_Task_Hooks;
|
||||
Init_RTS;
|
||||
|
||||
-- Register the environment task
|
||||
declare
|
||||
|
@ -46,7 +46,4 @@ procedure Initialize_Task_Hooks is
|
||||
Result : OSI.STATUS;
|
||||
begin
|
||||
taskCreateHookAdd (Register'Access);
|
||||
-- Register the environment task
|
||||
Result := Register (OSI.taskIdSelf);
|
||||
pragma Assert (Result /= -1);
|
||||
end Initialize_Task_Hooks;
|
||||
|
3614
gcc/ada/Make-lang.in
3614
gcc/ada/Make-lang.in
File diff suppressed because it is too large
Load Diff
@ -41,9 +41,8 @@ package body Exception_Data is
|
||||
-----------------------
|
||||
|
||||
function Address_Image (A : System.Address) return String;
|
||||
-- Returns at string of the form 0xhhhhhhhhh for 32-bit addresses
|
||||
-- or 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are
|
||||
-- in lower case.
|
||||
-- Returns at string of the form 0xhhhhhhhhh for an address, with
|
||||
-- leading zeros suppressed. Hex characters a-f are in lower case.
|
||||
|
||||
procedure Append_Info_Nat
|
||||
(N : Natural;
|
||||
@ -66,22 +65,19 @@ package body Exception_Data is
|
||||
-- we then use three intermediate functions :
|
||||
|
||||
function Basic_Exception_Information
|
||||
(X : Exception_Occurrence)
|
||||
return String;
|
||||
(X : Exception_Occurrence) return String;
|
||||
-- Returns the basic exception information string associated with a
|
||||
-- given exception occurrence. This is the common part shared by both
|
||||
-- Exception_Information and Tailored_Exception_Infomation.
|
||||
|
||||
function Basic_Exception_Traceback
|
||||
(X : Exception_Occurrence)
|
||||
return String;
|
||||
(X : Exception_Occurrence) return String;
|
||||
-- Returns an image of the complete call chain associated with an
|
||||
-- exception occurence in its most basic form, that is as a raw sequence
|
||||
-- of hexadecimal binary addresses.
|
||||
|
||||
function Tailored_Exception_Traceback
|
||||
(X : Exception_Occurrence)
|
||||
return String;
|
||||
(X : Exception_Occurrence) return String;
|
||||
-- Returns an image of the complete call chain associated with an
|
||||
-- exception occurrence, either in its basic form if no decorator is
|
||||
-- in place, or as formatted by the decorator otherwise.
|
||||
@ -121,10 +117,11 @@ package body Exception_Data is
|
||||
begin
|
||||
P := S'Last;
|
||||
N := To_Integer (A);
|
||||
while N /= 0 loop
|
||||
loop
|
||||
S (P) := H (Integer (N mod 16));
|
||||
P := P - 1;
|
||||
N := N / 16;
|
||||
exit when N = 0;
|
||||
end loop;
|
||||
|
||||
S (P - 1) := '0';
|
||||
@ -184,8 +181,7 @@ package body Exception_Data is
|
||||
---------------------------------
|
||||
|
||||
function Basic_Exception_Information
|
||||
(X : Exception_Occurrence)
|
||||
return String
|
||||
(X : Exception_Occurrence) return String
|
||||
is
|
||||
Name : constant String := Exception_Name (X);
|
||||
Msg : constant String := Exception_Message (X);
|
||||
@ -251,8 +247,7 @@ package body Exception_Data is
|
||||
-------------------------------
|
||||
|
||||
function Basic_Exception_Traceback
|
||||
(X : Exception_Occurrence)
|
||||
return String
|
||||
(X : Exception_Occurrence) return String
|
||||
is
|
||||
Info_Maxlen : constant Natural := 35 + X.Num_Tracebacks * 19;
|
||||
-- Maximum length of the information string we are building, with :
|
||||
@ -460,8 +455,7 @@ package body Exception_Data is
|
||||
----------------------------------
|
||||
|
||||
function Tailored_Exception_Traceback
|
||||
(X : Exception_Occurrence)
|
||||
return String
|
||||
(X : Exception_Occurrence) return String
|
||||
is
|
||||
-- We indeed reference the decorator *wrapper* from here and not the
|
||||
-- decorator itself. The purpose of the local variable Wrapper is to
|
||||
@ -491,8 +485,7 @@ package body Exception_Data is
|
||||
------------------------------------
|
||||
|
||||
function Tailored_Exception_Information
|
||||
(X : Exception_Occurrence)
|
||||
return String
|
||||
(X : Exception_Occurrence) return String
|
||||
is
|
||||
-- The tailored exception information is simply the basic information
|
||||
-- associated with the tailored call chain backtrace.
|
||||
|
@ -72,10 +72,14 @@ struct lang_type GTY(())
|
||||
#define TYPE_FAT_POINTER_P(NODE) \
|
||||
(TREE_CODE (NODE) == RECORD_TYPE && TYPE_IS_FAT_POINTER_P (NODE))
|
||||
|
||||
/* For integral types, nonzero if this is a packed array type. Such
|
||||
types should not be extended to a larger size. */
|
||||
/* For integral types and array types, nonzero if this is a packed array type.
|
||||
Such types should not be extended to a larger size. */
|
||||
#define TYPE_PACKED_ARRAY_TYPE_P(NODE) TYPE_LANG_FLAG_0 (NODE)
|
||||
|
||||
#define TYPE_IS_PACKED_ARRAY_TYPE_P(NODE) \
|
||||
((TREE_CODE (NODE) == INTEGER_TYPE || TREE_CODE (NODE) == ARRAY_TYPE) \
|
||||
&& TYPE_PACKED_ARRAY_TYPE_P (NODE))
|
||||
|
||||
/* For INTEGER_TYPE, nonzero if this is a modular type with a modulus that
|
||||
is not equal to two to the power of its mode's size. */
|
||||
#define TYPE_MODULAR_P(NODE) TYPE_LANG_FLAG_1 (INTEGER_TYPE_CHECK (NODE))
|
||||
|
@ -2465,13 +2465,15 @@ __gnat_copy_attribs (char *from, char *to, int mode)
|
||||
extern void __gnat_install_locks (void (*) (void), void (*) (void));
|
||||
|
||||
/* This function offers a hook for libgnarl to set the
|
||||
locking subprograms for libgcc_eh. */
|
||||
locking subprograms for libgcc_eh.
|
||||
This is only needed on OpenVMS, since other platforms use standard
|
||||
--enable-threads=posix option, or similar. */
|
||||
|
||||
void
|
||||
__gnatlib_install_locks (void (*lock) (void) ATTRIBUTE_UNUSED,
|
||||
void (*unlock) (void) ATTRIBUTE_UNUSED)
|
||||
{
|
||||
#ifdef IN_RTS
|
||||
#if defined (IN_RTS) && defined (VMS)
|
||||
__gnat_install_locks (lock, unlock);
|
||||
/* There is a bootstrap path issue if adaint is build with this
|
||||
symbol unresolved for the stage1 compiler. Since the compiler
|
||||
|
@ -1992,6 +1992,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|
||||
debug_no_type_hash = 0;
|
||||
TYPE_CONVENTION_FORTRAN_P (gnu_type)
|
||||
= (Convention (gnat_entity) == Convention_Fortran);
|
||||
TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
|
||||
= Is_Packed_Array_Type (gnat_entity);
|
||||
|
||||
/* If our size depends on a placeholder and the maximum size doesn't
|
||||
overflow, use it. */
|
||||
@ -5752,11 +5754,6 @@ validate_size (Uint uint_size,
|
||||
else
|
||||
gnat_error_node = gnat_object;
|
||||
|
||||
/* Don't give errors on packed array types; we'll be giving the error on
|
||||
the type itself soon enough. */
|
||||
if (Is_Packed_Array_Type (gnat_object))
|
||||
gnat_error_node = Empty;
|
||||
|
||||
/* Return 0 if no size was specified, either because Esize was not Present or
|
||||
the specified size was zero. */
|
||||
if (No (uint_size) || uint_size == No_Uint)
|
||||
@ -5791,11 +5788,11 @@ validate_size (Uint uint_size,
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* If this is an integral type, the front-end has verified the size, so we
|
||||
need not do it here (which would entail checking against the bounds).
|
||||
However, if this is an aliased object, it may not be smaller than the
|
||||
type of the object. */
|
||||
if (INTEGRAL_TYPE_P (gnu_type) && ! TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
|
||||
/* If this is an integral type or a packed array type, the front-end has
|
||||
verified the size, so we need not do it here (which would entail
|
||||
checking against the bounds). However, if this is an aliased object, it
|
||||
may not be smaller than the type of the object. */
|
||||
if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
|
||||
&& ! (kind == VAR_DECL && Is_Aliased (gnat_object)))
|
||||
return size;
|
||||
|
||||
|
@ -1660,9 +1660,9 @@ package Einfo is
|
||||
-- Is_Bit_Packed_Array (Flag122) [implementation base type only]
|
||||
-- Present in all entities. This flag is set for a packed array
|
||||
-- type that is bit packed (i.e. the component size is known by the
|
||||
-- front end and is in the range 1-7, 9-15, or 17-31). Is_Packed is
|
||||
-- always set if Is_Bit_Packed_Array is set, but it is possible for
|
||||
-- Is_Packed to be set without Is_Bit_Packed_Array or the case of an
|
||||
-- front end and is in the range 1-7, 9-15, 17-31, or 33-63). Is_Packed
|
||||
-- is always set if Is_Bit_Packed_Array is set, but it is possible for
|
||||
-- Is_Packed to be set without Is_Bit_Packed_Array for the case of an
|
||||
-- array having one or more index types that are enumeration types
|
||||
-- with non-standard enumeration representations.
|
||||
|
||||
|
@ -1408,6 +1408,12 @@ package body Errout is
|
||||
Warnings.Table (Warnings.Last).Start := Source_Ptr'First;
|
||||
Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last;
|
||||
end if;
|
||||
|
||||
-- Set all (???) the error nodes to Empty:
|
||||
|
||||
Error_Msg_Node_1 := Empty;
|
||||
Error_Msg_Node_2 := Empty;
|
||||
|
||||
end Initialize;
|
||||
|
||||
-----------------
|
||||
|
@ -106,8 +106,7 @@ package body Exp_Aggr is
|
||||
Target : Node_Id;
|
||||
Flist : Node_Id := Empty;
|
||||
Obj : Entity_Id := Empty;
|
||||
Is_Limited_Ancestor_Expansion : Boolean := False)
|
||||
return List_Id;
|
||||
Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id;
|
||||
-- N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type
|
||||
-- of the aggregate. Target is an expression containing the
|
||||
-- location on which the component by component assignments will
|
||||
@ -175,8 +174,7 @@ package body Exp_Aggr is
|
||||
Into : Node_Id;
|
||||
Scalar_Comp : Boolean;
|
||||
Indices : List_Id := No_List;
|
||||
Flist : Node_Id := Empty)
|
||||
return List_Id;
|
||||
Flist : Node_Id := Empty) return List_Id;
|
||||
-- This recursive routine returns a list of statements containing the
|
||||
-- loops and assignments that are needed for the expansion of the array
|
||||
-- aggregate N.
|
||||
@ -207,8 +205,7 @@ package body Exp_Aggr is
|
||||
Typ : Entity_Id;
|
||||
Target : Node_Id;
|
||||
Flist : Node_Id := Empty;
|
||||
Obj : Entity_Id := Empty)
|
||||
return List_Id;
|
||||
Obj : Entity_Id := Empty) return List_Id;
|
||||
-- N is a nested (record or array) aggregate that has been marked
|
||||
-- with 'Delay_Expansion'. Typ is the expected type of the
|
||||
-- aggregate and Target is a (duplicable) expression that will
|
||||
@ -225,8 +222,7 @@ package body Exp_Aggr is
|
||||
function Make_OK_Assignment_Statement
|
||||
(Sloc : Source_Ptr;
|
||||
Name : Node_Id;
|
||||
Expression : Node_Id)
|
||||
return Node_Id;
|
||||
Expression : Node_Id) return Node_Id;
|
||||
-- This is like Make_Assignment_Statement, except that Assignment_OK
|
||||
-- is set in the left operand. All assignments built by this unit
|
||||
-- use this routine. This is needed to deal with assignments to
|
||||
@ -405,8 +401,7 @@ package body Exp_Aggr is
|
||||
Into : Node_Id;
|
||||
Scalar_Comp : Boolean;
|
||||
Indices : List_Id := No_List;
|
||||
Flist : Node_Id := Empty)
|
||||
return List_Id
|
||||
Flist : Node_Id := Empty) return List_Id
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Index_Base : constant Entity_Id := Base_Type (Etype (Index));
|
||||
@ -1281,8 +1276,7 @@ package body Exp_Aggr is
|
||||
Target : Node_Id;
|
||||
Flist : Node_Id := Empty;
|
||||
Obj : Entity_Id := Empty;
|
||||
Is_Limited_Ancestor_Expansion : Boolean := False)
|
||||
return List_Id
|
||||
Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
L : constant List_Id := New_List;
|
||||
@ -1333,8 +1327,7 @@ package body Exp_Aggr is
|
||||
Typ : Entity_Id;
|
||||
F : Node_Id;
|
||||
Attach : Node_Id;
|
||||
Init_Pr : Boolean)
|
||||
return List_Id;
|
||||
Init_Pr : Boolean) return List_Id;
|
||||
-- returns the list of statements necessary to initialize the internal
|
||||
-- controller of the (possible) ancestor typ into target and attach
|
||||
-- it to finalization list F. Init_Pr conditions the call to the
|
||||
@ -1530,8 +1523,7 @@ package body Exp_Aggr is
|
||||
Typ : Entity_Id;
|
||||
F : Node_Id;
|
||||
Attach : Node_Id;
|
||||
Init_Pr : Boolean)
|
||||
return List_Id
|
||||
Init_Pr : Boolean) return List_Id
|
||||
is
|
||||
L : constant List_Id := New_List;
|
||||
Ref : Node_Id;
|
||||
@ -2432,10 +2424,9 @@ package body Exp_Aggr is
|
||||
Typ : constant Entity_Id := Etype (N);
|
||||
|
||||
function Flatten
|
||||
(N : Node_Id;
|
||||
Ix : Node_Id;
|
||||
Ixb : Node_Id)
|
||||
return Boolean;
|
||||
(N : Node_Id;
|
||||
Ix : Node_Id;
|
||||
Ixb : Node_Id) return Boolean;
|
||||
-- Convert the aggregate into a purely positional form if possible.
|
||||
|
||||
function Is_Flat (N : Node_Id; Dims : Int) return Boolean;
|
||||
@ -2446,10 +2437,9 @@ package body Exp_Aggr is
|
||||
-------------
|
||||
|
||||
function Flatten
|
||||
(N : Node_Id;
|
||||
Ix : Node_Id;
|
||||
Ixb : Node_Id)
|
||||
return Boolean
|
||||
(N : Node_Id;
|
||||
Ix : Node_Id;
|
||||
Ixb : Node_Id) return Boolean
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Blo : constant Node_Id := Type_Low_Bound (Etype (Ixb));
|
||||
@ -4483,8 +4473,9 @@ package body Exp_Aggr is
|
||||
----------------------------
|
||||
|
||||
function Has_Default_Init_Comps (N : Node_Id) return Boolean is
|
||||
Comps : constant List_Id := Component_Associations (N);
|
||||
C : Node_Id;
|
||||
Comps : constant List_Id := Component_Associations (N);
|
||||
C : Node_Id;
|
||||
|
||||
begin
|
||||
pragma Assert (Nkind (N) = N_Aggregate
|
||||
or else Nkind (N) = N_Extension_Aggregate);
|
||||
@ -4533,8 +4524,7 @@ package body Exp_Aggr is
|
||||
Typ : Entity_Id;
|
||||
Target : Node_Id;
|
||||
Flist : Node_Id := Empty;
|
||||
Obj : Entity_Id := Empty)
|
||||
return List_Id
|
||||
Obj : Entity_Id := Empty) return List_Id
|
||||
is
|
||||
begin
|
||||
if Is_Record_Type (Etype (N)) then
|
||||
@ -4558,8 +4548,7 @@ package body Exp_Aggr is
|
||||
function Make_OK_Assignment_Statement
|
||||
(Sloc : Source_Ptr;
|
||||
Name : Node_Id;
|
||||
Expression : Node_Id)
|
||||
return Node_Id
|
||||
Expression : Node_Id) return Node_Id
|
||||
is
|
||||
begin
|
||||
Set_Assignment_OK (Name);
|
||||
|
@ -1817,16 +1817,19 @@ package body Freeze is
|
||||
-- fields with component clauses, where we must check the size.
|
||||
-- This is not done till the freeze point, since for fixed-point
|
||||
-- types, we do not know the size until the type is frozen.
|
||||
-- Similar processing applies to bit packed arrays.
|
||||
|
||||
if Is_First_Subtype (Rec) then
|
||||
Comp := First_Component (Rec);
|
||||
|
||||
while Present (Comp) loop
|
||||
if Present (Component_Clause (Comp))
|
||||
and then Is_Fixed_Point_Type (Etype (Comp))
|
||||
and then (Is_Fixed_Point_Type (Etype (Comp))
|
||||
or else
|
||||
Is_Bit_Packed_Array (Etype (Comp)))
|
||||
then
|
||||
Check_Size
|
||||
(Component_Clause (Comp),
|
||||
(Component_Name (Component_Clause (Comp)),
|
||||
Etype (Comp),
|
||||
Esize (Comp),
|
||||
Junk);
|
||||
@ -2382,6 +2385,29 @@ package body Freeze is
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- For bit-packed arrays, check the size
|
||||
|
||||
if Is_Bit_Packed_Array (E)
|
||||
and then Known_Esize (E)
|
||||
then
|
||||
declare
|
||||
Discard : Boolean;
|
||||
SizC : constant Node_Id := Size_Clause (E);
|
||||
|
||||
begin
|
||||
-- It is not clear if it is possible to have no size
|
||||
-- clause at this stage, but this is not worth worrying
|
||||
-- about. Post the error on the entity name in the size
|
||||
-- clause if present, else on the type entity itself.
|
||||
|
||||
if Present (SizC) then
|
||||
Check_Size (Name (SizC), E, Esize (E), Discard);
|
||||
else
|
||||
Check_Size (E, E, Esize (E), Discard);
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- Check one common case of a size given where the array
|
||||
-- needs to be packed, but was not so the size cannot be
|
||||
-- honored. This would of course be caught by the backend,
|
||||
|
@ -39,9 +39,11 @@ package body GNAT.Debug_Utilities is
|
||||
H : constant array (0 .. 15) of Character := "0123456789ABCDEF";
|
||||
-- Table of hex digits
|
||||
|
||||
--------------------------
|
||||
-- Image (address case) --
|
||||
--------------------------
|
||||
-----------
|
||||
-- Image --
|
||||
-----------
|
||||
|
||||
-- Address case
|
||||
|
||||
function Image (A : Address) return Image_String is
|
||||
S : Image_String;
|
||||
@ -71,9 +73,11 @@ package body GNAT.Debug_Utilities is
|
||||
return S;
|
||||
end Image;
|
||||
|
||||
-------------------------
|
||||
-- Image (string case) --
|
||||
-------------------------
|
||||
-----------
|
||||
-- Image --
|
||||
-----------
|
||||
|
||||
-- String case
|
||||
|
||||
function Image (S : String) return String is
|
||||
W : String (1 .. 2 * S'Length + 2);
|
||||
|
@ -207,7 +207,7 @@ procedure Gnatchop is
|
||||
-- Local subprograms --
|
||||
-----------------------
|
||||
|
||||
procedure Error_Msg (Message : String);
|
||||
procedure Error_Msg (Message : String; Warning : Boolean := False);
|
||||
-- Produce an error message on standard error output
|
||||
|
||||
procedure File_Time_Stamp (Name : C_File_Name; Time : OS_Time);
|
||||
@ -337,10 +337,13 @@ procedure Gnatchop is
|
||||
-- Error_Msg --
|
||||
---------------
|
||||
|
||||
procedure Error_Msg (Message : String) is
|
||||
procedure Error_Msg (Message : String; Warning : Boolean := False) is
|
||||
begin
|
||||
Put_Line (Standard_Error, Message);
|
||||
Set_Exit_Status (Failure);
|
||||
|
||||
if not Warning then
|
||||
Set_Exit_Status (Failure);
|
||||
end if;
|
||||
|
||||
if Exit_On_Error then
|
||||
raise Terminate_Program;
|
||||
@ -1687,7 +1690,7 @@ begin
|
||||
|
||||
if Unit.Last = 0 then
|
||||
if not Write_gnat_adc then
|
||||
Error_Msg ("no compilation units found");
|
||||
Error_Msg ("no compilation units found", Warning => True);
|
||||
end if;
|
||||
|
||||
goto No_Files_Written;
|
||||
@ -1739,7 +1742,7 @@ begin
|
||||
-- been written.
|
||||
|
||||
if not Write_gnat_adc then
|
||||
Error_Msg ("no source files written");
|
||||
Error_Msg ("no source files written", Warning => True);
|
||||
end if;
|
||||
|
||||
return;
|
||||
|
@ -3001,7 +3001,8 @@ package body Make is
|
||||
if Global_Attribute_Present then
|
||||
declare
|
||||
Path : constant String :=
|
||||
Absolute_Path (Global_Attribute.Value, Main_Project);
|
||||
Absolute_Path
|
||||
(Global_Attribute.Value, Global_Attribute.Project);
|
||||
begin
|
||||
if not Is_Regular_File (Path) then
|
||||
Make_Failed
|
||||
@ -3033,7 +3034,8 @@ package body Make is
|
||||
if Local_Attribute_Present then
|
||||
declare
|
||||
Path : constant String :=
|
||||
Absolute_Path (Local_Attribute.Value, For_Project);
|
||||
Absolute_Path
|
||||
(Local_Attribute.Value, Local_Attribute.Project);
|
||||
begin
|
||||
if not Is_Regular_File (Path) then
|
||||
Make_Failed
|
||||
@ -3725,6 +3727,16 @@ package body Make is
|
||||
And_Save => False);
|
||||
end if;
|
||||
|
||||
else
|
||||
-- If we use a project file, we have already checked that a main
|
||||
-- specified on the command line with directory information has the
|
||||
-- path name corresponding to a correct source in the project tree.
|
||||
-- So, we don't need the directory information to be taken into
|
||||
-- account by Find_File, and in fact it may lead to take the wrong
|
||||
-- sources for other compilation units, when there are extending
|
||||
-- projects.
|
||||
|
||||
Opt.Look_In_Primary_Dir := False;
|
||||
end if;
|
||||
|
||||
-- If the user wants a program without a main subprogram, add the
|
||||
|
@ -50,6 +50,11 @@ package body Osint is
|
||||
-- Standard prefix, computed dynamically the first time Relocate_Path
|
||||
-- is called, and cached for subsequent calls.
|
||||
|
||||
Empty : aliased String := "";
|
||||
No_Dir : constant String_Ptr := Empty'Access;
|
||||
-- Used in Locate_File as a fake directory when Name is already an
|
||||
-- absolute path.
|
||||
|
||||
-------------------------------------
|
||||
-- Use of Name_Find and Name_Enter --
|
||||
-------------------------------------
|
||||
@ -1430,7 +1435,12 @@ package body Osint is
|
||||
Dir_Name : String_Ptr;
|
||||
|
||||
begin
|
||||
if T = Library then
|
||||
-- If Name is already an absolute path, do not look for a directory
|
||||
|
||||
if Is_Absolute_Path (Name) then
|
||||
Dir_Name := No_Dir;
|
||||
|
||||
elsif T = Library then
|
||||
Dir_Name := Lib_Search_Directories.Table (Dir);
|
||||
|
||||
else pragma Assert (T /= Config);
|
||||
|
@ -300,9 +300,14 @@ package body Ch10 is
|
||||
Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));
|
||||
|
||||
else
|
||||
Error_Msg_SC ("compilation unit expected");
|
||||
Cunit_Error_Flag := True;
|
||||
Resync_Cunit;
|
||||
if Operating_Mode = Check_Syntax and then Token = Tok_EOF then
|
||||
Error_Msg_SC ("?file contains no compilation units");
|
||||
|
||||
else
|
||||
Error_Msg_SC ("compilation unit expected");
|
||||
Cunit_Error_Flag := True;
|
||||
Resync_Cunit;
|
||||
end if;
|
||||
|
||||
-- If we are at an end of file, then just quit, the above error
|
||||
-- message was complaint enough.
|
||||
|
@ -1402,6 +1402,7 @@ package body Ch4 is
|
||||
else
|
||||
Set_Expression (Assoc_Node, P_Expression);
|
||||
end if;
|
||||
|
||||
return Assoc_Node;
|
||||
end P_Record_Or_Array_Component_Association;
|
||||
|
||||
|
@ -991,8 +991,8 @@ package body Prj.Nmsc is
|
||||
The_Unit_Data := Units.Table (The_Unit_Id);
|
||||
|
||||
if Specs then
|
||||
if The_Unit_Data.File_Names (Specification).Project /=
|
||||
Project
|
||||
if not Check_Project
|
||||
(The_Unit_Data.File_Names (Specification).Project)
|
||||
then
|
||||
Error_Msg
|
||||
(Project,
|
||||
@ -1001,8 +1001,8 @@ package body Prj.Nmsc is
|
||||
end if;
|
||||
|
||||
else
|
||||
if The_Unit_Data.File_Names (Com.Body_Part).Project /=
|
||||
Project
|
||||
if not Check_Project
|
||||
(The_Unit_Data.File_Names (Com.Body_Part).Project)
|
||||
then
|
||||
Error_Msg
|
||||
(Project,
|
||||
|
@ -56,8 +56,9 @@ package body Prj.Proc is
|
||||
-- arguments are not null string.
|
||||
|
||||
procedure Add_Attributes
|
||||
(Decl : in out Declarations;
|
||||
First : Attribute_Node_Id);
|
||||
(Project : Project_Id;
|
||||
Decl : in out Declarations;
|
||||
First : Attribute_Node_Id);
|
||||
-- Add all attributes, starting with First, with their default
|
||||
-- values to the package or project with declarations Decl.
|
||||
|
||||
@ -66,21 +67,18 @@ package body Prj.Proc is
|
||||
From_Project_Node : Project_Node_Id;
|
||||
Pkg : Package_Id;
|
||||
First_Term : Project_Node_Id;
|
||||
Kind : Variable_Kind)
|
||||
return Variable_Value;
|
||||
Kind : Variable_Kind) return Variable_Value;
|
||||
-- From N_Expression project node From_Project_Node, compute the value
|
||||
-- of an expression and return it as a Variable_Value.
|
||||
|
||||
function Imported_Or_Extended_Project_From
|
||||
(Project : Project_Id;
|
||||
With_Name : Name_Id)
|
||||
return Project_Id;
|
||||
With_Name : Name_Id) return Project_Id;
|
||||
-- Find an imported or extended project of Project whose name is With_Name
|
||||
|
||||
function Package_From
|
||||
(Project : Project_Id;
|
||||
With_Name : Name_Id)
|
||||
return Package_Id;
|
||||
With_Name : Name_Id) return Package_Id;
|
||||
-- Find the package of Project whose name is With_Name
|
||||
|
||||
procedure Process_Declarative_Items
|
||||
@ -143,8 +141,9 @@ package body Prj.Proc is
|
||||
--------------------
|
||||
|
||||
procedure Add_Attributes
|
||||
(Decl : in out Declarations;
|
||||
First : Attribute_Node_Id)
|
||||
(Project : Project_Id;
|
||||
Decl : in out Declarations;
|
||||
First : Attribute_Node_Id)
|
||||
is
|
||||
The_Attribute : Attribute_Node_Id := First;
|
||||
Attribute_Data : Attribute_Record;
|
||||
@ -171,7 +170,8 @@ package body Prj.Proc is
|
||||
|
||||
when Single =>
|
||||
New_Attribute :=
|
||||
(Kind => Single,
|
||||
(Project => Project,
|
||||
Kind => Single,
|
||||
Location => No_Location,
|
||||
Default => True,
|
||||
Value => Empty_String);
|
||||
@ -180,7 +180,8 @@ package body Prj.Proc is
|
||||
|
||||
when List =>
|
||||
New_Attribute :=
|
||||
(Kind => List,
|
||||
(Project => Project,
|
||||
Kind => List,
|
||||
Location => No_Location,
|
||||
Default => True,
|
||||
Values => Nil_String);
|
||||
@ -225,8 +226,7 @@ package body Prj.Proc is
|
||||
From_Project_Node : Project_Node_Id;
|
||||
Pkg : Package_Id;
|
||||
First_Term : Project_Node_Id;
|
||||
Kind : Variable_Kind)
|
||||
return Variable_Value
|
||||
Kind : Variable_Kind) return Variable_Value
|
||||
is
|
||||
The_Term : Project_Node_Id := First_Term;
|
||||
-- The term in the expression list
|
||||
@ -241,6 +241,7 @@ package body Prj.Proc is
|
||||
-- Reference to the last string elements in Result, when Kind is List.
|
||||
|
||||
begin
|
||||
Result.Project := Project;
|
||||
Result.Location := Location_Of (First_Term);
|
||||
|
||||
-- Process each term of the expression, starting with First_Term
|
||||
@ -536,14 +537,16 @@ package body Prj.Proc is
|
||||
Expression_Kind_Of (The_Current_Term) = List
|
||||
then
|
||||
The_Variable :=
|
||||
(Kind => List,
|
||||
(Project => Project,
|
||||
Kind => List,
|
||||
Location => No_Location,
|
||||
Default => True,
|
||||
Values => Nil_String);
|
||||
|
||||
else
|
||||
The_Variable :=
|
||||
(Kind => Single,
|
||||
(Project => Project,
|
||||
Kind => Single,
|
||||
Location => No_Location,
|
||||
Default => True,
|
||||
Value => Empty_String);
|
||||
@ -739,8 +742,7 @@ package body Prj.Proc is
|
||||
|
||||
function Imported_Or_Extended_Project_From
|
||||
(Project : Project_Id;
|
||||
With_Name : Name_Id)
|
||||
return Project_Id
|
||||
With_Name : Name_Id) return Project_Id
|
||||
is
|
||||
Data : constant Project_Data := Projects.Table (Project);
|
||||
List : Project_List := Data.Imported_Projects;
|
||||
@ -779,8 +781,7 @@ package body Prj.Proc is
|
||||
|
||||
function Package_From
|
||||
(Project : Project_Id;
|
||||
With_Name : Name_Id)
|
||||
return Package_Id
|
||||
With_Name : Name_Id) return Package_Id
|
||||
is
|
||||
Data : constant Project_Data := Projects.Table (Project);
|
||||
Result : Package_Id := Data.Decl.Packages;
|
||||
@ -1035,7 +1036,8 @@ package body Prj.Proc is
|
||||
-- Set the default values of the attributes
|
||||
|
||||
Add_Attributes
|
||||
(Packages.Table (New_Pkg).Decl,
|
||||
(Project,
|
||||
Packages.Table (New_Pkg).Decl,
|
||||
Package_Attributes.Table
|
||||
(Package_Id_Of (Current_Item)).First_Attribute);
|
||||
|
||||
@ -1260,6 +1262,8 @@ package body Prj.Proc is
|
||||
|
||||
Array_Elements.Table (New_Element) :=
|
||||
Array_Elements.Table (Orig_Element);
|
||||
Array_Elements.Table (New_Element).Value.Project :=
|
||||
Project;
|
||||
|
||||
-- Adjust the Next link
|
||||
|
||||
@ -1856,7 +1860,7 @@ package body Prj.Proc is
|
||||
Processed_Data.Extended_By := Extended_By;
|
||||
Processed_Data.Naming := Standard_Naming_Data;
|
||||
|
||||
Add_Attributes (Processed_Data.Decl, Attribute_First);
|
||||
Add_Attributes (Project, Processed_Data.Decl, Attribute_First);
|
||||
With_Clause := First_With_Clause_Of (From_Project_Node);
|
||||
|
||||
while With_Clause /= Empty_Node loop
|
||||
|
@ -306,7 +306,8 @@ package body Prj is
|
||||
Element :=
|
||||
(Index => Lang,
|
||||
Index_Case_Sensitive => False,
|
||||
Value => (Kind => Single,
|
||||
Value => (Project => No_Project,
|
||||
Kind => Single,
|
||||
Location => No_Location,
|
||||
Default => False,
|
||||
Value => Default_Spec_Suffix),
|
||||
@ -341,7 +342,8 @@ package body Prj is
|
||||
Element :=
|
||||
(Index => Lang,
|
||||
Index_Case_Sensitive => False,
|
||||
Value => (Kind => Single,
|
||||
Value => (Project => No_Project,
|
||||
Kind => Single,
|
||||
Location => No_Location,
|
||||
Default => False,
|
||||
Value => Default_Body_Suffix),
|
||||
|
@ -77,6 +77,10 @@ package Prj is
|
||||
|
||||
function Empty_String return Name_Id;
|
||||
|
||||
type Project_Id is new Nat;
|
||||
No_Project : constant Project_Id := 0;
|
||||
-- Id of a Project File
|
||||
|
||||
type String_List_Id is new Nat;
|
||||
Nil_String : constant String_List_Id := 0;
|
||||
type String_Element is record
|
||||
@ -107,6 +111,7 @@ package Prj is
|
||||
-- while processing the project tree (unknown package name).
|
||||
|
||||
type Variable_Value (Kind : Variable_Kind := Undefined) is record
|
||||
Project : Project_Id := No_Project;
|
||||
Location : Source_Ptr := No_Location;
|
||||
Default : Boolean := False;
|
||||
case Kind is
|
||||
@ -122,7 +127,8 @@ package Prj is
|
||||
-- Default is True if the current value is the default one for the variable
|
||||
|
||||
Nil_Variable_Value : constant Variable_Value :=
|
||||
(Kind => Undefined,
|
||||
(Project => No_Project,
|
||||
Kind => Undefined,
|
||||
Location => No_Location,
|
||||
Default => False);
|
||||
-- Value of a non existing variable or array element
|
||||
@ -303,10 +309,6 @@ package Prj is
|
||||
-- Returns True if Left and Right are the same naming scheme
|
||||
-- not considering Specs and Bodies.
|
||||
|
||||
type Project_Id is new Nat;
|
||||
No_Project : constant Project_Id := 0;
|
||||
-- Id of a Project File
|
||||
|
||||
type Project_List is new Nat;
|
||||
Empty_Project_List : constant Project_List := 0;
|
||||
-- A list of project files.
|
||||
|
@ -33,6 +33,11 @@
|
||||
|
||||
-- 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;
|
||||
|
||||
with Unchecked_Conversion;
|
||||
|
@ -2202,6 +2202,10 @@ package body Sem_Aggr is
|
||||
-- C : Lim := (..., others => <>);
|
||||
-- end record;
|
||||
|
||||
----------------------------
|
||||
-- Check_Non_Limited_Type --
|
||||
----------------------------
|
||||
|
||||
procedure Check_Non_Limited_Type is
|
||||
begin
|
||||
if Is_Limited_Type (Etype (Compon))
|
||||
@ -2223,6 +2227,8 @@ package body Sem_Aggr is
|
||||
end if;
|
||||
end Check_Non_Limited_Type;
|
||||
|
||||
-- Start of processing for Get_Value
|
||||
|
||||
begin
|
||||
Mbox_Present := False;
|
||||
|
||||
@ -2254,8 +2260,8 @@ package body Sem_Aggr is
|
||||
else
|
||||
return Expression (Parent (Compon));
|
||||
end if;
|
||||
else
|
||||
|
||||
else
|
||||
Check_Non_Limited_Type;
|
||||
|
||||
if Present (Others_Etype) and then
|
||||
@ -2295,8 +2301,8 @@ package body Sem_Aggr is
|
||||
else
|
||||
Expr := Expression (Parent (Compon));
|
||||
end if;
|
||||
else
|
||||
|
||||
else
|
||||
Check_Non_Limited_Type;
|
||||
|
||||
if Present (Next (Selector_Name)) then
|
||||
@ -2926,13 +2932,11 @@ package body Sem_Aggr is
|
||||
Typech := Base_Type (Etype (Component));
|
||||
|
||||
elsif Typech /= Base_Type (Etype (Component)) then
|
||||
|
||||
if not Box_Present (Parent (Selectr)) then
|
||||
Error_Msg_N
|
||||
("components in choice list must have same type",
|
||||
Selectr);
|
||||
end if;
|
||||
|
||||
end if;
|
||||
|
||||
Next (Selectr);
|
||||
|
@ -757,9 +757,11 @@ package body Sem_Ch12 is
|
||||
F_Copy : List_Id)
|
||||
return List_Id
|
||||
is
|
||||
Actual_Types : constant Elist_Id := New_Elmt_List;
|
||||
Assoc : constant List_Id := New_List;
|
||||
Defaults : constant Elist_Id := New_Elmt_List;
|
||||
Actual_Types : constant Elist_Id := New_Elmt_List;
|
||||
Assoc : constant List_Id := New_List;
|
||||
Defaults : constant Elist_Id := New_Elmt_List;
|
||||
Gen_Unit : constant Entity_Id := Defining_Entity
|
||||
(Parent (F_Copy));
|
||||
Actuals : List_Id;
|
||||
Actual : Node_Id;
|
||||
Formal : Node_Id;
|
||||
@ -985,8 +987,11 @@ package body Sem_Ch12 is
|
||||
Defining_Identifier (Analyzed_Formal));
|
||||
|
||||
if No (Match) then
|
||||
Error_Msg_NE ("missing actual for instantiation of &",
|
||||
Instantiation_Node, Defining_Identifier (Formal));
|
||||
Error_Msg_NE
|
||||
("missing actual&",
|
||||
Instantiation_Node, Defining_Identifier (Formal));
|
||||
Error_Msg_NE ("\in instantiation of & declared#",
|
||||
Instantiation_Node, Gen_Unit);
|
||||
Abandon_Instantiation (Instantiation_Node);
|
||||
|
||||
else
|
||||
@ -1071,9 +1076,10 @@ package body Sem_Ch12 is
|
||||
|
||||
if No (Match) then
|
||||
Error_Msg_NE
|
||||
("missing actual for instantiation of&",
|
||||
Instantiation_Node,
|
||||
Defining_Identifier (Formal));
|
||||
("missing actual&",
|
||||
Instantiation_Node, Defining_Identifier (Formal));
|
||||
Error_Msg_NE ("\in instantiation of & declared#",
|
||||
Instantiation_Node, Gen_Unit);
|
||||
|
||||
Abandon_Instantiation (Instantiation_Node);
|
||||
|
||||
@ -1105,8 +1111,17 @@ package body Sem_Ch12 is
|
||||
end loop;
|
||||
|
||||
if Num_Actuals > Num_Matched then
|
||||
Error_Msg_N
|
||||
("unmatched actuals in instantiation", Instantiation_Node);
|
||||
if Present (Selector_Name (Actual)) then
|
||||
Error_Msg_NE
|
||||
("unmatched actual&",
|
||||
Actual, Selector_Name (Actual));
|
||||
Error_Msg_NE ("\in instantiation of& declared#",
|
||||
Actual, Gen_Unit);
|
||||
else
|
||||
Error_Msg_NE
|
||||
("unmatched actual in instantiation of& declared#",
|
||||
Actual, Gen_Unit);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
elsif Present (Actuals) then
|
||||
@ -4641,19 +4656,37 @@ package body Sem_Ch12 is
|
||||
else
|
||||
-- If the associated node is still defined, the entity in
|
||||
-- it is global, and must be copied to the instance.
|
||||
-- If this copy is being made for a body to inline, it is
|
||||
-- applied to an instantiated tree, and the entity is already
|
||||
-- present and must be also preserved.
|
||||
|
||||
if Present (Get_Associated_Node (N)) then
|
||||
if Nkind (Get_Associated_Node (N)) = Nkind (N) then
|
||||
Set_Entity (New_N, Entity (Get_Associated_Node (N)));
|
||||
Check_Private_View (N);
|
||||
declare
|
||||
Assoc : constant Node_Id := Get_Associated_Node (N);
|
||||
begin
|
||||
if Present (Assoc) then
|
||||
if Nkind (Assoc) = Nkind (N) then
|
||||
Set_Entity (New_N, Entity (Assoc));
|
||||
Check_Private_View (N);
|
||||
|
||||
elsif Nkind (Get_Associated_Node (N)) = N_Function_Call then
|
||||
Set_Entity (New_N, Entity (Name (Get_Associated_Node (N))));
|
||||
elsif Nkind (Assoc) = N_Function_Call then
|
||||
Set_Entity (New_N, Entity (Name (Assoc)));
|
||||
|
||||
else
|
||||
Set_Entity (New_N, Empty);
|
||||
elsif (Nkind (Assoc) = N_Defining_Identifier
|
||||
or else Nkind (Assoc) = N_Defining_Character_Literal
|
||||
or else Nkind (Assoc) = N_Defining_Operator_Symbol)
|
||||
and then Expander_Active
|
||||
then
|
||||
-- Inlining case: we are copying a tree that contains
|
||||
-- global entities, which are preserved in the copy
|
||||
-- to be used for subsequent inlining.
|
||||
|
||||
null;
|
||||
|
||||
else
|
||||
Set_Entity (New_N, Empty);
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- For expanded name, we must copy the Prefix and Selector_Name
|
||||
@ -5618,6 +5651,8 @@ package body Sem_Ch12 is
|
||||
Generic_Flags.Init;
|
||||
Generic_Renamings_HTable.Reset;
|
||||
Circularity_Detected := False;
|
||||
Exchanged_Views := No_Elist;
|
||||
Hidden_Entities := No_Elist;
|
||||
end Initialize;
|
||||
|
||||
----------------------------
|
||||
@ -6586,8 +6621,10 @@ package body Sem_Ch12 is
|
||||
|
||||
else
|
||||
Error_Msg_NE
|
||||
("missing actual for instantiation of &",
|
||||
Instantiation_Node, Formal_Sub);
|
||||
("missing actual&", Instantiation_Node, Formal_Sub);
|
||||
Error_Msg_NE
|
||||
("\in instantiation of & declared#",
|
||||
Instantiation_Node, Scope (Analyzed_S));
|
||||
Abandon_Instantiation (Instantiation_Node);
|
||||
end if;
|
||||
|
||||
@ -6729,8 +6766,12 @@ package body Sem_Ch12 is
|
||||
|
||||
if No (Actual) then
|
||||
Error_Msg_NE
|
||||
("missing actual for instantiation of &",
|
||||
("missing actual&",
|
||||
Instantiation_Node, Formal_Id);
|
||||
Error_Msg_NE
|
||||
("\in instantiation of & declared#",
|
||||
Instantiation_Node,
|
||||
Scope (Defining_Identifier (Analyzed_Formal)));
|
||||
Abandon_Instantiation (Instantiation_Node);
|
||||
end if;
|
||||
|
||||
@ -6893,8 +6934,11 @@ package body Sem_Ch12 is
|
||||
|
||||
else
|
||||
Error_Msg_NE
|
||||
("missing actual for instantiation of &",
|
||||
Instantiation_Node, Formal_Id);
|
||||
("missing actual&",
|
||||
Instantiation_Node, Formal_Id);
|
||||
Error_Msg_NE ("\in instantiation of & declared#",
|
||||
Instantiation_Node,
|
||||
Scope (Defining_Identifier (Analyzed_Formal)));
|
||||
|
||||
if Is_Scalar_Type
|
||||
(Etype (Defining_Identifier (Analyzed_Formal)))
|
||||
|
@ -1881,7 +1881,7 @@ package body Sem_Ch13 is
|
||||
Biased : Boolean;
|
||||
|
||||
Max_Bit_So_Far : Uint;
|
||||
-- Records the maximum bit position so far. If all field positoins
|
||||
-- Records the maximum bit position so far. If all field positions
|
||||
-- are monotonically increasing, then we can skip the circuit for
|
||||
-- checking for overlap, since no overlap is possible.
|
||||
|
||||
@ -2153,10 +2153,9 @@ package body Sem_Ch13 is
|
||||
CC, Rectype);
|
||||
end if;
|
||||
|
||||
-- This information is also set in the
|
||||
-- corresponding component of the base type,
|
||||
-- found by accessing the Original_Record_Component
|
||||
-- link if it is present.
|
||||
-- This information is also set in the corresponding
|
||||
-- component of the base type, found by accessing the
|
||||
-- Original_Record_Component link if it is present.
|
||||
|
||||
Ocomp := Original_Record_Component (Comp);
|
||||
|
||||
@ -2848,21 +2847,68 @@ package body Sem_Ch13 is
|
||||
begin
|
||||
Biased := False;
|
||||
|
||||
-- Immediate return if size is same as standard size or if composite
|
||||
-- item, or generic type, or type with previous errors.
|
||||
-- Dismiss cases for generic types or types with previous errors
|
||||
|
||||
if No (UT)
|
||||
or else UT = Any_Type
|
||||
or else Is_Generic_Type (UT)
|
||||
or else Is_Generic_Type (Root_Type (UT))
|
||||
or else Is_Composite_Type (UT)
|
||||
or else (Known_Esize (UT) and then Siz = Esize (UT))
|
||||
then
|
||||
return;
|
||||
|
||||
-- Check case of bit packed array
|
||||
|
||||
elsif Is_Array_Type (UT)
|
||||
and then Known_Static_Component_Size (UT)
|
||||
and then Is_Bit_Packed_Array (UT)
|
||||
then
|
||||
declare
|
||||
Asiz : Uint;
|
||||
Indx : Node_Id;
|
||||
Ityp : Entity_Id;
|
||||
|
||||
begin
|
||||
Asiz := Component_Size (UT);
|
||||
Indx := First_Index (UT);
|
||||
loop
|
||||
Ityp := Etype (Indx);
|
||||
|
||||
-- If non-static bound, then we are not in the business of
|
||||
-- trying to check the length, and indeed an error will be
|
||||
-- issued elsewhere, since sizes of non-static array types
|
||||
-- cannot be set implicitly or explicitly.
|
||||
|
||||
if not Is_Static_Subtype (Ityp) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Otherwise accumulate next dimension
|
||||
|
||||
Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) -
|
||||
Expr_Value (Type_Low_Bound (Ityp)) +
|
||||
Uint_1);
|
||||
|
||||
Next_Index (Indx);
|
||||
exit when No (Indx);
|
||||
end loop;
|
||||
|
||||
if Asiz <= Siz then
|
||||
return;
|
||||
else
|
||||
Error_Msg_Uint_1 := Asiz;
|
||||
Error_Msg_NE
|
||||
("size for& too small, minimum allowed is ^", N, T);
|
||||
end if;
|
||||
end;
|
||||
|
||||
-- All other composite types are ignored
|
||||
|
||||
elsif Is_Composite_Type (UT) then
|
||||
return;
|
||||
|
||||
-- For fixed-point types, don't check minimum if type is not frozen,
|
||||
-- since type is not known till then
|
||||
-- at freeze time.
|
||||
-- since we don't know all the characteristics of the type that can
|
||||
-- affect the size (e.g. a specified small) till freeze time.
|
||||
|
||||
elsif Is_Fixed_Point_Type (UT)
|
||||
and then not Is_Frozen (UT)
|
||||
@ -2872,6 +2918,14 @@ package body Sem_Ch13 is
|
||||
-- Cases for which a minimum check is required
|
||||
|
||||
else
|
||||
-- Ignore if specified size is correct for the type
|
||||
|
||||
if Known_Esize (UT) and then Siz = Esize (UT) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Otherwise get minimum size
|
||||
|
||||
M := UI_From_Int (Minimum_Size (UT));
|
||||
|
||||
if Siz < M then
|
||||
|
@ -338,13 +338,18 @@ package body Sem_Ch4 is
|
||||
Check_Restriction (No_Protected_Type_Allocators, N);
|
||||
end if;
|
||||
|
||||
if Nkind (Expression (E)) /= N_Aggregate
|
||||
and then Is_Limited_Type (Type_Id)
|
||||
if Is_Limited_Type (Type_Id)
|
||||
and then Comes_From_Source (N)
|
||||
and then not In_Instance_Body
|
||||
then
|
||||
Error_Msg_N ("initialization not allowed for limited types", N);
|
||||
Explain_Limited_Type (Type_Id, N);
|
||||
if Extensions_Allowed
|
||||
and then Nkind (Expression (E)) = N_Aggregate
|
||||
then
|
||||
null;
|
||||
else
|
||||
Error_Msg_N ("initialization not allowed for limited types", N);
|
||||
Explain_Limited_Type (Type_Id, N);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Analyze_And_Resolve (Expression (E), Type_Id);
|
||||
|
@ -82,11 +82,7 @@ package body Sem_Ch6 is
|
||||
-- Analyze a generic subprogram body. N is the body to be analyzed,
|
||||
-- and Gen_Id is the defining entity Id for the corresponding spec.
|
||||
|
||||
function Build_Body_To_Inline
|
||||
(N : Node_Id;
|
||||
Subp : Entity_Id;
|
||||
Orig_Body : Node_Id)
|
||||
return Boolean;
|
||||
procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id);
|
||||
-- If a subprogram has pragma Inline and inlining is active, use generic
|
||||
-- machinery to build an unexpanded body for the subprogram. This body is
|
||||
-- subsequenty used for inline expansions at call sites. If subprogram can
|
||||
@ -132,8 +128,7 @@ package body Sem_Ch6 is
|
||||
|
||||
function Is_Non_Overriding_Operation
|
||||
(Prev_E : Entity_Id;
|
||||
New_E : Entity_Id)
|
||||
return Boolean;
|
||||
New_E : Entity_Id) return Boolean;
|
||||
-- Enforce the rule given in 12.3(18): a private operation in an instance
|
||||
-- overrides an inherited operation only if the corresponding operation
|
||||
-- was overriding in the generic. This can happen for primitive operations
|
||||
@ -156,8 +151,7 @@ package body Sem_Ch6 is
|
||||
(T1 : Entity_Id;
|
||||
T2 : Entity_Id;
|
||||
Ctype : Conformance_Type;
|
||||
Get_Inst : Boolean := False)
|
||||
return Boolean;
|
||||
Get_Inst : Boolean := False) return Boolean;
|
||||
-- Check that two formal parameter types conform, checking both
|
||||
-- for equality of base types, and where required statically
|
||||
-- matching subtypes, depending on the setting of Ctype.
|
||||
@ -1142,9 +1136,7 @@ package body Sem_Ch6 is
|
||||
(Front_End_Inlining
|
||||
or else Configurable_Run_Time_Mode)))
|
||||
then
|
||||
if Build_Body_To_Inline (N, Spec_Id, Copy_Separate_Tree (N)) then
|
||||
null;
|
||||
end if;
|
||||
Build_Body_To_Inline (N, Spec_Id);
|
||||
end if;
|
||||
|
||||
-- Now we can go on to analyze the body
|
||||
@ -1492,12 +1484,7 @@ package body Sem_Ch6 is
|
||||
-- Build_Body_To_Inline --
|
||||
--------------------------
|
||||
|
||||
function Build_Body_To_Inline
|
||||
(N : Node_Id;
|
||||
Subp : Entity_Id;
|
||||
Orig_Body : Node_Id)
|
||||
return Boolean
|
||||
is
|
||||
procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is
|
||||
Decl : constant Node_Id := Unit_Declaration_Node (Subp);
|
||||
Original_Body : Node_Id;
|
||||
Body_To_Analyze : Node_Id;
|
||||
@ -1732,7 +1719,7 @@ package body Sem_Ch6 is
|
||||
if Nkind (Decl) = N_Subprogram_Declaration
|
||||
and then Present (Body_To_Inline (Decl))
|
||||
then
|
||||
return True; -- Done already.
|
||||
return; -- Done already.
|
||||
|
||||
-- Functions that return unconstrained composite types will require
|
||||
-- secondary stack handling, and cannot currently be inlined.
|
||||
@ -1744,64 +1731,13 @@ package body Sem_Ch6 is
|
||||
then
|
||||
Cannot_Inline
|
||||
("cannot inline & (unconstrained return type)?", N, Subp);
|
||||
return False;
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- We need to capture references to the formals in order to substitute
|
||||
-- the actuals at the point of inlining, i.e. instantiation. To treat
|
||||
-- the formals as globals to the body to inline, we nest it within
|
||||
-- a dummy parameterless subprogram, declared within the real one.
|
||||
|
||||
Original_Body := Orig_Body;
|
||||
|
||||
-- Within an instance, the current tree is already the result of
|
||||
-- a generic copy, and not what we need for subsequent inlining.
|
||||
-- We create the required body by doing an instantiating copy, to
|
||||
-- obtain the proper partially analyzed tree.
|
||||
|
||||
if In_Instance then
|
||||
if No (Generic_Parent (Specification (N))) then
|
||||
return False;
|
||||
|
||||
elsif Is_Child_Unit (Scope (Current_Scope)) then
|
||||
return False;
|
||||
|
||||
elsif Scope (Current_Scope) = Cunit_Entity (Main_Unit) then
|
||||
|
||||
-- compiling an instantiation. There is no point in generating
|
||||
-- bodies to inline, because they will not be used.
|
||||
|
||||
return False;
|
||||
|
||||
else
|
||||
Body_To_Analyze :=
|
||||
Copy_Generic_Node
|
||||
(Generic_Parent (Specification (N)), Empty,
|
||||
Instantiating => True);
|
||||
end if;
|
||||
|
||||
-- Case of not in an instance
|
||||
|
||||
else
|
||||
Body_To_Analyze :=
|
||||
Copy_Generic_Node (Original_Body, Empty,
|
||||
Instantiating => False);
|
||||
end if;
|
||||
|
||||
Set_Parameter_Specifications (Specification (Original_Body), No_List);
|
||||
Set_Defining_Unit_Name (Specification (Original_Body),
|
||||
Make_Defining_Identifier (Sloc (N), New_Internal_Name ('S')));
|
||||
Set_Corresponding_Spec (Original_Body, Empty);
|
||||
|
||||
if Ekind (Subp) = E_Function then
|
||||
Set_Subtype_Mark (Specification (Original_Body),
|
||||
New_Occurrence_Of (Etype (Subp), Sloc (N)));
|
||||
end if;
|
||||
|
||||
if Present (Declarations (Orig_Body))
|
||||
and then Has_Excluded_Declaration (Declarations (Orig_Body))
|
||||
if Present (Declarations (N))
|
||||
and then Has_Excluded_Declaration (Declarations (N))
|
||||
then
|
||||
return False;
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Present (Handled_Statement_Sequence (N)) then
|
||||
@ -1810,12 +1746,12 @@ package body Sem_Ch6 is
|
||||
("cannot inline& (exception handler)?",
|
||||
First (Exception_Handlers (Handled_Statement_Sequence (N))),
|
||||
Subp);
|
||||
return False;
|
||||
return;
|
||||
elsif
|
||||
Has_Excluded_Statement
|
||||
(Statements (Handled_Statement_Sequence (N)))
|
||||
then
|
||||
return False;
|
||||
return;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
@ -1827,16 +1763,36 @@ package body Sem_Ch6 is
|
||||
and then not Is_Always_Inlined (Subp)
|
||||
then
|
||||
Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
|
||||
return False;
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Has_Pending_Instantiation then
|
||||
Cannot_Inline
|
||||
("cannot inline& (forward instance within enclosing body)?",
|
||||
N, Subp);
|
||||
return False;
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Within an instance, the body to inline must be treated as a nested
|
||||
-- generic, so that the proper global references are preserved.
|
||||
|
||||
if In_Instance then
|
||||
Save_Env (Scope (Current_Scope), Scope (Current_Scope));
|
||||
Original_Body := Copy_Generic_Node (N, Empty, True);
|
||||
else
|
||||
Original_Body := Copy_Separate_Tree (N);
|
||||
end if;
|
||||
|
||||
-- We need to capture references to the formals in order to substitute
|
||||
-- the actuals at the point of inlining, i.e. instantiation. To treat
|
||||
-- the formals as globals to the body to inline, we nest it within
|
||||
-- a dummy parameterless subprogram, declared within the real one.
|
||||
|
||||
Set_Parameter_Specifications (Specification (Original_Body), No_List);
|
||||
Set_Defining_Unit_Name (Specification (Original_Body),
|
||||
Make_Defining_Identifier (Sloc (N), New_Internal_Name ('S')));
|
||||
Set_Corresponding_Spec (Original_Body, Empty);
|
||||
|
||||
Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
|
||||
|
||||
-- Set return type of function, which is also global and does not need
|
||||
@ -1866,7 +1822,10 @@ package body Sem_Ch6 is
|
||||
Set_Body_To_Inline (Decl, Original_Body);
|
||||
Set_Ekind (Defining_Entity (Original_Body), Ekind (Subp));
|
||||
Set_Is_Inlined (Subp);
|
||||
return True;
|
||||
|
||||
if In_Instance then
|
||||
Restore_Env;
|
||||
end if;
|
||||
end Build_Body_To_Inline;
|
||||
|
||||
-------------------
|
||||
@ -2972,8 +2931,7 @@ package body Sem_Ch6 is
|
||||
(T1 : Entity_Id;
|
||||
T2 : Entity_Id;
|
||||
Ctype : Conformance_Type;
|
||||
Get_Inst : Boolean := False)
|
||||
return Boolean
|
||||
Get_Inst : Boolean := False) return Boolean
|
||||
is
|
||||
Type_1 : Entity_Id := T1;
|
||||
Type_2 : Entity_Id := T2;
|
||||
@ -3475,8 +3433,7 @@ package body Sem_Ch6 is
|
||||
|
||||
function Fully_Conformant_Expressions
|
||||
(Given_E1 : Node_Id;
|
||||
Given_E2 : Node_Id)
|
||||
return Boolean
|
||||
Given_E2 : Node_Id) return Boolean
|
||||
is
|
||||
E1 : constant Node_Id := Original_Node (Given_E1);
|
||||
E2 : constant Node_Id := Original_Node (Given_E2);
|
||||
@ -3849,8 +3806,7 @@ package body Sem_Ch6 is
|
||||
|
||||
function Fully_Conformant_Discrete_Subtypes
|
||||
(Given_S1 : Node_Id;
|
||||
Given_S2 : Node_Id)
|
||||
return Boolean
|
||||
Given_S2 : Node_Id) return Boolean
|
||||
is
|
||||
S1 : constant Node_Id := Original_Node (Given_S1);
|
||||
S2 : constant Node_Id := Original_Node (Given_S2);
|
||||
@ -3942,8 +3898,7 @@ package body Sem_Ch6 is
|
||||
|
||||
function Is_Non_Overriding_Operation
|
||||
(Prev_E : Entity_Id;
|
||||
New_E : Entity_Id)
|
||||
return Boolean
|
||||
New_E : Entity_Id) return Boolean
|
||||
is
|
||||
Formal : Entity_Id;
|
||||
F_Typ : Entity_Id;
|
||||
@ -3956,8 +3911,7 @@ package body Sem_Ch6 is
|
||||
|
||||
function Types_Correspond
|
||||
(P_Type : Entity_Id;
|
||||
N_Type : Entity_Id)
|
||||
return Boolean;
|
||||
N_Type : Entity_Id) return Boolean;
|
||||
-- Returns true if and only if the types (or designated types
|
||||
-- in the case of anonymous access types) are the same or N_Type
|
||||
-- is derived directly or indirectly from P_Type.
|
||||
@ -4005,8 +3959,7 @@ package body Sem_Ch6 is
|
||||
|
||||
function Types_Correspond
|
||||
(P_Type : Entity_Id;
|
||||
N_Type : Entity_Id)
|
||||
return Boolean
|
||||
N_Type : Entity_Id) return Boolean
|
||||
is
|
||||
Prev_Type : Entity_Id := Base_Type (P_Type);
|
||||
New_Type : Entity_Id := Base_Type (N_Type);
|
||||
@ -5245,7 +5198,6 @@ package body Sem_Ch6 is
|
||||
|
||||
function Type_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
|
||||
Result : Boolean;
|
||||
|
||||
begin
|
||||
Check_Conformance (New_Id, Old_Id, Type_Conformant, False, Result);
|
||||
return Result;
|
||||
|
@ -928,6 +928,7 @@ package body Sprint is
|
||||
Set_Debug_Sloc;
|
||||
Sprint_Bar_List (Choices (Node));
|
||||
Write_Str (" => ");
|
||||
|
||||
if Box_Present (Node) then
|
||||
Write_Str_With_Col_Check ("<>");
|
||||
else
|
||||
|
@ -148,7 +148,7 @@ static tree merge_sizes (tree, tree, tree, int, int);
|
||||
static tree compute_related_constant (tree, tree);
|
||||
static tree split_plus (tree, tree *);
|
||||
static int value_zerop (tree);
|
||||
static tree float_type_for_size (int, enum machine_mode);
|
||||
static tree float_type_for_precision (int, enum machine_mode);
|
||||
static tree convert_to_fat_pointer (tree, tree);
|
||||
static tree convert_to_thin_pointer (tree, tree);
|
||||
static tree make_descriptor_field (const char *,tree, tree, tree);
|
||||
@ -1992,7 +1992,7 @@ gnat_type_for_size (unsigned precision, int unsignedp)
|
||||
/* Likewise for floating-point types. */
|
||||
|
||||
static tree
|
||||
float_type_for_size (int precision, enum machine_mode mode)
|
||||
float_type_for_precision (int precision, enum machine_mode mode)
|
||||
{
|
||||
tree t;
|
||||
char type_name[20];
|
||||
@ -2023,7 +2023,7 @@ tree
|
||||
gnat_type_for_mode (enum machine_mode mode, int unsignedp)
|
||||
{
|
||||
if (GET_MODE_CLASS (mode) == MODE_FLOAT)
|
||||
return float_type_for_size (GET_MODE_BITSIZE (mode), mode);
|
||||
return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
|
||||
else
|
||||
return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
|
||||
}
|
||||
|
Loading…
x
Reference in New Issue
Block a user