Skip to content

R
riscv-gcc-1
Commit 22cb89b5 by Arnaud Charlet
Options

[multiple changes] 

2010-06-18  Ed Schonberg  <schonberg@adacore.com>

	* exp_util.adb (Make_Subtype_From_Expr): If the unconstrained type is
	the class-wide type for a private extension, and the completion is a
	subtype, set the type of the class-wide type to the base type of the
	full view.

2010-06-18  Robert Dewar  <dewar@adacore.com>

	* g-socket.ads, sem_aggr.adb, einfo.ads, sem_elim.adb,
	sem_intr.adb, sem_eval.adb: Minor reformatting

2010-06-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_type.adb (Is_Ancestor): If either type is private, examine full
	view.

From-SVN: r160966
parent e9672ebe
Showing with 203 additions and 181 deletions
gcc/ada/ChangeLog
2010-06-18 Ed Schonberg <schonberg@adacore.com>
* exp_util.adb (Make_Subtype_From_Expr): If the unconstrained type is
the class-wide type for a private extension, and the completion is a
subtype, set the type of the class-wide type to the base type of the
full view.
2010-06-18 Robert Dewar <dewar@adacore.com>
* g-socket.ads, sem_aggr.adb, einfo.ads, sem_elim.adb,
sem_intr.adb, sem_eval.adb: Minor reformatting
2010-06-18 Ed Schonberg <schonberg@adacore.com>
* sem_type.adb (Is_Ancestor): If either type is private, examine full
view.
2010-06-18 Thomas Quinot <quinot@adacore.com> 2010-06-18 Thomas Quinot <quinot@adacore.com>
* g-socket.adb, g-socket.ads (Check_Selector): Make Selector an IN * g-socket.adb, g-socket.ads (Check_Selector): Make Selector an IN
......
gcc/ada/einfo.ads
...@@ -6189,7 +6189,7 @@ package Einfo is ...@@ -6189,7 +6189,7 @@ package Einfo is
-- have an RM_Size value of zero). -- have an RM_Size value of zero).
-- In two cases, Known_Static_Esize and Known_Static_RM_Size, there is one -- In two cases, Known_Static_Esize and Known_Static_RM_Size, there is one
-- more consideration, which is that we always return false for generic -- more consideration, which is that we always return False for generic
-- types. Within a template, the size can look known, because of the fake -- types. Within a template, the size can look known, because of the fake
-- size values we put in template types, but they are not really known and -- size values we put in template types, but they are not really known and
-- anyone testing if they are known within the template should get False as -- anyone testing if they are known within the template should get False as
......
gcc/ada/exp_util.adb
...@@ -3475,7 +3475,7 @@ package body Exp_Util is ...@@ -3475,7 +3475,7 @@ package body Exp_Util is
-- Generate warning if not suppressed -- Generate warning if not suppressed
if W then if W then
Error_Msg_F Error_Msg_F -- CODEFIX???
("?this code can never be executed and has been deleted!", N); ("?this code can never be executed and has been deleted!", N);
end if; end if;
end if; end if;
...@@ -4052,6 +4052,20 @@ package body Exp_Util is ...@@ -4052,6 +4052,20 @@ package body Exp_Util is
-- additional intermediate type to handle the assignment). -- additional intermediate type to handle the assignment).
if Expander_Active and then Tagged_Type_Expansion then if Expander_Active and then Tagged_Type_Expansion then
-- If this is the class_wide type of a completion that is
-- a record subtype, set the type of the class_wide type
-- to be the full base type, for use in the expanded code
-- for the equivalent type. Should this be done earlier when
-- the completion is analyzed ???
if Is_Private_Type (Etype (Unc_Typ))
and then
Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
then
Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
end if;
EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E); EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
end if; end if;
......
gcc/ada/g-socket.ads
...@@ -1088,9 +1088,11 @@ package GNAT.Sockets is ...@@ -1088,9 +1088,11 @@ package GNAT.Sockets is
-- R_Socket_Set or W_Socket_Set. Status is set to Expired if no socket was -- R_Socket_Set or W_Socket_Set. Status is set to Expired if no socket was
-- ready after a Timeout expiration. Status is set to Aborted if an abort -- ready after a Timeout expiration. Status is set to Aborted if an abort
-- signal has been received while checking socket status. -- signal has been received while checking socket status.
--
-- Note that two different Socket_Set_Type objects must be passed as -- Note that two different Socket_Set_Type objects must be passed as
-- R_Socket_Set and W_Socket_Set (even if they denote the same set of -- R_Socket_Set and W_Socket_Set (even if they denote the same set of
-- Sockets), or some event may be lost. -- Sockets), or some event may be lost.
--
-- Socket_Error is raised when the select(2) system call returns an -- Socket_Error is raised when the select(2) system call returns an
-- error condition, or when a read error occurs on the signalling socket -- error condition, or when a read error occurs on the signalling socket
-- used for the implementation of Abort_Selector. -- used for the implementation of Abort_Selector.
......
gcc/ada/sem_aggr.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1431,7 +1431,8 @@ package body Sem_Aggr is ...@@ -1431,7 +1431,8 @@ package body Sem_Aggr is
-- aggregate must not be enclosed in parentheses. -- aggregate must not be enclosed in parentheses.
if Paren_Count (Expr) /= 0 then if Paren_Count (Expr) /= 0 then
Error_Msg_N ("no parenthesis allowed here", Expr); Error_Msg_N -- CODEFIX???
("no parenthesis allowed here", Expr);
end if; end if;
Make_String_Into_Aggregate (Expr); Make_String_Into_Aggregate (Expr);
...@@ -1443,8 +1444,9 @@ package body Sem_Aggr is ...@@ -1443,8 +1444,9 @@ package body Sem_Aggr is
-- a missing component association for a 1-aggregate. -- a missing component association for a 1-aggregate.
if Paren_Count (Expr) > 0 then if Paren_Count (Expr) > 0 then
Error_Msg_N ("\if single-component aggregate is intended," Error_Msg_N -- CODEFIX???
& " write e.g. (1 ='> ...)", Expr); ("\if single-component aggregate is intended,"
& " write e.g. (1 ='> ...)", Expr);
end if; end if;
return Failure; return Failure;
end if; end if;
...@@ -1547,13 +1549,13 @@ package body Sem_Aggr is ...@@ -1547,13 +1549,13 @@ package body Sem_Aggr is
if Choice /= First (Choices (Assoc)) if Choice /= First (Choices (Assoc))
or else Present (Next (Choice)) or else Present (Next (Choice))
then then
Error_Msg_N Error_Msg_N -- CODEFIX???
("OTHERS must appear alone in a choice list", Choice); ("OTHERS must appear alone in a choice list", Choice);
return Failure; return Failure;
end if; end if;
if Present (Next (Assoc)) then if Present (Next (Assoc)) then
Error_Msg_N Error_Msg_N -- CODEFIX???
("OTHERS must appear last in an aggregate", Choice); ("OTHERS must appear last in an aggregate", Choice);
return Failure; return Failure;
end if; end if;
...@@ -2504,8 +2506,8 @@ package body Sem_Aggr is ...@@ -2504,8 +2506,8 @@ package body Sem_Aggr is
-- New_Assoc_List the discriminant value specified in the ancestor part. -- New_Assoc_List the discriminant value specified in the ancestor part.
-- --
-- If the aggregate is in a context with expansion delayed, it will be -- If the aggregate is in a context with expansion delayed, it will be
-- reanalyzed, The inherited discriminant values must not be reinserted -- reanalyzed. The inherited discriminant values must not be reinserted
-- in the component list to prevent spurious errors, but it must be -- in the component list to prevent spurious errors, but they must be
-- present on first analysis to build the proper subtype indications. -- present on first analysis to build the proper subtype indications.
-- The flag Inherited_Discriminant is used to prevent the re-insertion. -- The flag Inherited_Discriminant is used to prevent the re-insertion.
...@@ -3023,13 +3025,15 @@ package body Sem_Aggr is ...@@ -3023,13 +3025,15 @@ package body Sem_Aggr is
if Selector_Name /= First (Choices (Assoc)) if Selector_Name /= First (Choices (Assoc))
or else Present (Next (Selector_Name)) or else Present (Next (Selector_Name))
then then
Error_Msg_N ("OTHERS must appear alone in a choice list", Error_Msg_N -- CODEFIX???
Selector_Name); ("OTHERS must appear alone in a choice list",
Selector_Name);
return; return;
elsif Present (Next (Assoc)) then elsif Present (Next (Assoc)) then
Error_Msg_N ("OTHERS must appear last in an aggregate", Error_Msg_N -- CODEFIX???
Selector_Name); ("OTHERS must appear last in an aggregate",
Selector_Name);
return; return;
-- (Ada2005): If this is an association with a box, -- (Ada2005): If this is an association with a box,
...@@ -3242,10 +3246,11 @@ package body Sem_Aggr is ...@@ -3242,10 +3246,11 @@ package body Sem_Aggr is
if Nkind (Parent (Base_Type (Root_Typ))) = if Nkind (Parent (Base_Type (Root_Typ))) =
N_Private_Type_Declaration N_Private_Type_Declaration
then then
Error_Msg_NE Error_Msg_NE -- CODEFIX???
("type of aggregate has private ancestor&!", ("type of aggregate has private ancestor&!",
N, Root_Typ); N, Root_Typ);
Error_Msg_N ("must use extension aggregate!", N); Error_Msg_N -- CODEFIX???
("must use extension aggregate!", N);
return; return;
end if; end if;
...@@ -3278,10 +3283,11 @@ package body Sem_Aggr is ...@@ -3278,10 +3283,11 @@ package body Sem_Aggr is
N_Private_Extension_Declaration N_Private_Extension_Declaration
then then
if Nkind (N) /= N_Extension_Aggregate then if Nkind (N) /= N_Extension_Aggregate then
Error_Msg_NE Error_Msg_NE -- CODEFIX???
("type of aggregate has private ancestor&!", ("type of aggregate has private ancestor&!",
N, Parent_Typ); N, Parent_Typ);
Error_Msg_N ("must use extension aggregate!", N); Error_Msg_N -- CODEFIX???
("must use extension aggregate!", N);
return; return;
elsif Parent_Typ /= Root_Typ then elsif Parent_Typ /= Root_Typ then
...@@ -3766,7 +3772,7 @@ package body Sem_Aggr is ...@@ -3766,7 +3772,7 @@ package body Sem_Aggr is
if No (Others_Etype) if No (Others_Etype)
and then not Others_Box and then not Others_Box
then then
Error_Msg_N Error_Msg_N -- CODEFIX???
("OTHERS must represent at least one component", Selectr); ("OTHERS must represent at least one component", Selectr);
end if; end if;
......
gcc/ada/sem_elim.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1997-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -295,11 +295,11 @@ package body Sem_Elim is ...@@ -295,11 +295,11 @@ package body Sem_Elim is
Up := Elmt.Unit_Name'Last; Up := Elmt.Unit_Name'Last;
-- If we are within a subunit, the name in the pragma has been -- If we are within a subunit, the name in the pragma has been
-- parsed as a child unit, but the current compilation unit is -- parsed as a child unit, but the current compilation unit is in
-- in fact the parent in which the subunit is embedded. We must -- fact the parent in which the subunit is embedded. We must skip
-- skip the first name which is that of the subunit to match -- the first name which is that of the subunit to match the pragma
-- the pragma specification. -- specification.
declare declare
Par : Node_Id; Par : Node_Id;
......
gcc/ada/sem_eval.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -2069,8 +2069,7 @@ package body Sem_Eval is ...@@ -2069,8 +2069,7 @@ package body Sem_Eval is
Right_Int : constant Uint := Expr_Value (Right); Right_Int : constant Uint := Expr_Value (Right);
begin begin
-- VMS includes bitwise operations on signed types
-- VMS includes bitwise operations on signed types.
if Is_Modular_Integer_Type (Etype (N)) if Is_Modular_Integer_Type (Etype (N))
or else Is_VMS_Operator (Entity (N)) or else Is_VMS_Operator (Entity (N))
...@@ -2149,9 +2148,7 @@ package body Sem_Eval is ...@@ -2149,9 +2148,7 @@ package body Sem_Eval is
-- Ignore if error in either operand, except to make sure that Any_Type -- Ignore if error in either operand, except to make sure that Any_Type
-- is properly propagated to avoid junk cascaded errors. -- is properly propagated to avoid junk cascaded errors.
if Etype (Left) = Any_Type if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
or else Etype (Right) = Any_Type
then
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
return; return;
end if; end if;
...@@ -2224,7 +2221,8 @@ package body Sem_Eval is ...@@ -2224,7 +2221,8 @@ package body Sem_Eval is
declare declare
Typlen : constant Uint := String_Type_Len (Etype (Right)); Typlen : constant Uint := String_Type_Len (Etype (Right));
Strlen : constant Uint := Strlen : constant Uint :=
UI_From_Int (String_Length (Strval (Get_String_Val (Left)))); UI_From_Int
(String_Length (Strval (Get_String_Val (Left))));
begin begin
Result := (Typlen = Strlen); Result := (Typlen = Strlen);
end; end;
...@@ -2316,8 +2314,8 @@ package body Sem_Eval is ...@@ -2316,8 +2314,8 @@ package body Sem_Eval is
Result : Uint; Result : Uint;
begin begin
-- Exponentiation of an integer raises the exception -- Exponentiation of an integer raises Constraint_Error for a
-- Constraint_Error for a negative exponent (RM 4.5.6) -- negative exponent (RM 4.5.6).
if Right_Int < 0 then if Right_Int < 0 then
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
...@@ -2432,9 +2430,9 @@ package body Sem_Eval is ...@@ -2432,9 +2430,9 @@ package body Sem_Eval is
begin begin
-- Can only fold if target is string or scalar and subtype is static. -- Can only fold if target is string or scalar and subtype is static.
-- Also, do not fold if our parent is an allocator (this is because -- Also, do not fold if our parent is an allocator (this is because the
-- the qualified expression is really part of the syntactic structure -- qualified expression is really part of the syntactic structure of an
-- of an allocator, and we do not want to end up with something that -- allocator, and we do not want to end up with something that
-- corresponds to "new 1" where the 1 is the result of folding a -- corresponds to "new 1" where the 1 is the result of folding a
-- qualified expression). -- qualified expression).
...@@ -2620,7 +2618,7 @@ package body Sem_Eval is ...@@ -2620,7 +2618,7 @@ package body Sem_Eval is
-- entity name, and the two X's are the same and K1 and K2 are -- entity name, and the two X's are the same and K1 and K2 are
-- known at compile time, in this case, the length can also be -- known at compile time, in this case, the length can also be
-- computed at compile time, even though the bounds are not -- computed at compile time, even though the bounds are not
-- known. A common case of this is e.g. (X'First..X'First+5). -- known. A common case of this is e.g. (X'First .. X'First+5).
Extract_Length : declare Extract_Length : declare
procedure Decompose_Expr procedure Decompose_Expr
...@@ -2879,9 +2877,9 @@ package body Sem_Eval is ...@@ -2879,9 +2877,9 @@ package body Sem_Eval is
-- Eval_Shift -- -- Eval_Shift --
---------------- ----------------
-- Shift operations are intrinsic operations that can never be static, -- Shift operations are intrinsic operations that can never be static, so
-- so the only processing required is to perform the required check for -- the only processing required is to perform the required check for a non
-- a non static context for the two operands. -- static context for the two operands.
-- Actually we could do some compile time evaluation here some time ??? -- Actually we could do some compile time evaluation here some time ???
...@@ -2895,8 +2893,8 @@ package body Sem_Eval is ...@@ -2895,8 +2893,8 @@ package body Sem_Eval is
-- Eval_Short_Circuit -- -- Eval_Short_Circuit --
------------------------ ------------------------
-- A short circuit operation is potentially static if both operands -- A short circuit operation is potentially static if both operands are
-- are potentially static (RM 4.9 (13)) -- potentially static (RM 4.9 (13)).
procedure Eval_Short_Circuit (N : Node_Id) is procedure Eval_Short_Circuit (N : Node_Id) is
Kind : constant Node_Kind := Nkind (N); Kind : constant Node_Kind := Nkind (N);
...@@ -2910,9 +2908,7 @@ package body Sem_Eval is ...@@ -2910,9 +2908,7 @@ package body Sem_Eval is
begin begin
-- Short circuit operations are never static in Ada 83 -- Short circuit operations are never static in Ada 83
if Ada_Version = Ada_83 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
and then Comes_From_Source (N)
then
Check_Non_Static_Context (Left); Check_Non_Static_Context (Left);
Check_Non_Static_Context (Right); Check_Non_Static_Context (Right);
return; return;
...@@ -2923,8 +2919,8 @@ package body Sem_Eval is ...@@ -2923,8 +2919,8 @@ package body Sem_Eval is
-- are a special case, they can still be foldable, even if the right -- are a special case, they can still be foldable, even if the right
-- operand raises constraint error. -- operand raises constraint error.
-- If either operand is Any_Type, just propagate to result and -- If either operand is Any_Type, just propagate to result and do not
-- do not try to fold, this prevents cascaded errors. -- try to fold, this prevents cascaded errors.
if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
...@@ -2997,8 +2993,8 @@ package body Sem_Eval is ...@@ -2997,8 +2993,8 @@ package body Sem_Eval is
-- Eval_Slice -- -- Eval_Slice --
---------------- ----------------
-- Slices can never be static, so the only processing required is to -- Slices can never be static, so the only processing required is to check
-- check for non-static context if an explicit range is given. -- for non-static context if an explicit range is given.
procedure Eval_Slice (N : Node_Id) is procedure Eval_Slice (N : Node_Id) is
Drange : constant Node_Id := Discrete_Range (N); Drange : constant Node_Id := Discrete_Range (N);
...@@ -3008,7 +3004,7 @@ package body Sem_Eval is ...@@ -3008,7 +3004,7 @@ package body Sem_Eval is
Check_Non_Static_Context (High_Bound (Drange)); Check_Non_Static_Context (High_Bound (Drange));
end if; end if;
-- A slice of the form A (subtype), when the subtype is the index of -- A slice of the form A (subtype), when the subtype is the index of
-- the type of A, is redundant, the slice can be replaced with A, and -- the type of A, is redundant, the slice can be replaced with A, and
-- this is worth a warning. -- this is worth a warning.
...@@ -3026,10 +3022,11 @@ package body Sem_Eval is ...@@ -3026,10 +3022,11 @@ package body Sem_Eval is
= Entity (Drange) = Entity (Drange)
then then
if Warn_On_Redundant_Constructs then if Warn_On_Redundant_Constructs then
Error_Msg_N ("redundant slice denotes whole array?", N); Error_Msg_N -- CODEFIX???
("redundant slice denotes whole array?", N);
end if; end if;
-- The following might be a useful optimization ???? -- The following might be a useful optimization????
-- Rewrite (N, New_Occurrence_Of (E, Sloc (N))); -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
end if; end if;
...@@ -3051,7 +3048,7 @@ package body Sem_Eval is ...@@ -3051,7 +3048,7 @@ package body Sem_Eval is
begin begin
-- Nothing to do if error type (handles cases like default expressions -- Nothing to do if error type (handles cases like default expressions
-- or generics where we have not yet fully resolved the type) -- or generics where we have not yet fully resolved the type).
if Bas = Any_Type or else Bas = Any_String then if Bas = Any_Type or else Bas = Any_String then
return; return;
...@@ -3069,7 +3066,7 @@ package body Sem_Eval is ...@@ -3069,7 +3066,7 @@ package body Sem_Eval is
end if; end if;
-- Here if Etype of string literal is normal Etype (not yet possible, -- Here if Etype of string literal is normal Etype (not yet possible,
-- but may be possible in future!) -- but may be possible in future).
elsif not Is_OK_Static_Expression elsif not Is_OK_Static_Expression
(Type_Low_Bound (Etype (First_Index (Typ)))) (Type_Low_Bound (Etype (First_Index (Typ))))
...@@ -3085,12 +3082,12 @@ package body Sem_Eval is ...@@ -3085,12 +3082,12 @@ package body Sem_Eval is
return; return;
end if; end if;
-- Test for illegal Ada 95 cases. A string literal is illegal in -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
-- Ada 95 if its bounds are outside the index base type and this -- if its bounds are outside the index base type and this index type is
-- index type is static. This can happen in only two ways. Either -- static. This can happen in only two ways. Either the string literal
-- the string literal is too long, or it is null, and the lower -- is too long, or it is null, and the lower bound is type'First. In
-- bound is type'First. In either case it is the upper bound that -- either case it is the upper bound that is out of range of the index
-- is out of range of the index type. -- type.
if Ada_Version >= Ada_95 then if Ada_Version >= Ada_95 then
if Root_Type (Bas) = Standard_String if Root_Type (Bas) = Standard_String
...@@ -3136,7 +3133,7 @@ package body Sem_Eval is ...@@ -3136,7 +3133,7 @@ package body Sem_Eval is
-- A type conversion is potentially static if its subtype mark is for a -- A type conversion is potentially static if its subtype mark is for a
-- static scalar subtype, and its operand expression is potentially static -- static scalar subtype, and its operand expression is potentially static
-- (RM 4.9 (10)) -- (RM 4.9(10)).
procedure Eval_Type_Conversion (N : Node_Id) is procedure Eval_Type_Conversion (N : Node_Id) is
Operand : constant Node_Id := Expression (N); Operand : constant Node_Id := Expression (N);
...@@ -3147,9 +3144,9 @@ package body Sem_Eval is ...@@ -3147,9 +3144,9 @@ package body Sem_Eval is
Fold : Boolean; Fold : Boolean;
function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean; function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
-- Returns true if type T is an integer type, or if it is a -- Returns true if type T is an integer type, or if it is a fixed-point
-- fixed-point type to be treated as an integer (i.e. the flag -- type to be treated as an integer (i.e. the flag Conversion_OK is set
-- Conversion_OK is set on the conversion node). -- on the conversion node).
function To_Be_Treated_As_Real (T : Entity_Id) return Boolean; function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
-- Returns true if type T is a floating-point type, or if it is a -- Returns true if type T is a floating-point type, or if it is a
...@@ -3283,7 +3280,7 @@ package body Sem_Eval is ...@@ -3283,7 +3280,7 @@ package body Sem_Eval is
------------------- -------------------
-- Predefined unary operators are static functions (RM 4.9(20)) and thus -- Predefined unary operators are static functions (RM 4.9(20)) and thus
-- are potentially static if the operand is potentially static (RM 4.9(7)) -- are potentially static if the operand is potentially static (RM 4.9(7)).
procedure Eval_Unary_Op (N : Node_Id) is procedure Eval_Unary_Op (N : Node_Id) is
Right : constant Node_Id := Right_Opnd (N); Right : constant Node_Id := Right_Opnd (N);
...@@ -3380,8 +3377,8 @@ package body Sem_Eval is ...@@ -3380,8 +3377,8 @@ package body Sem_Eval is
if Is_Entity_Name (N) then if Is_Entity_Name (N) then
Ent := Entity (N); Ent := Entity (N);
-- An enumeration literal that was either in the source or -- An enumeration literal that was either in the source or created
-- created as a result of static evaluation. -- as a result of static evaluation.
if Ekind (Ent) = E_Enumeration_Literal then if Ekind (Ent) = E_Enumeration_Literal then
return Enumeration_Rep (Ent); return Enumeration_Rep (Ent);
...@@ -3393,8 +3390,8 @@ package body Sem_Eval is ...@@ -3393,8 +3390,8 @@ package body Sem_Eval is
return Expr_Rep_Value (Constant_Value (Ent)); return Expr_Rep_Value (Constant_Value (Ent));
end if; end if;
-- An integer literal that was either in the source or created -- An integer literal that was either in the source or created as a
-- as a result of static evaluation. -- result of static evaluation.
elsif Kind = N_Integer_Literal then elsif Kind = N_Integer_Literal then
return Intval (N); return Intval (N);
...@@ -3421,11 +3418,11 @@ package body Sem_Eval is ...@@ -3421,11 +3418,11 @@ package body Sem_Eval is
pragma Assert (Kind = N_Character_Literal); pragma Assert (Kind = N_Character_Literal);
Ent := Entity (N); Ent := Entity (N);
-- Since Character literals of type Standard.Character don't -- Since Character literals of type Standard.Character don't have any
-- have any defining character literals built for them, they -- defining character literals built for them, they do not have their
-- do not have their Entity set, so just use their Char -- Entity set, so just use their Char code. Otherwise for user-
-- code. Otherwise for user-defined character literals use -- defined character literals use their Pos value as usual which is
-- their Pos value as usual which is the same as the Rep value. -- the same as the Rep value.
if No (Ent) then if No (Ent) then
return Char_Literal_Value (N); return Char_Literal_Value (N);
...@@ -3459,8 +3456,8 @@ package body Sem_Eval is ...@@ -3459,8 +3456,8 @@ package body Sem_Eval is
if Is_Entity_Name (N) then if Is_Entity_Name (N) then
Ent := Entity (N); Ent := Entity (N);
-- An enumeration literal that was either in the source or -- An enumeration literal that was either in the source or created as
-- created as a result of static evaluation. -- a result of static evaluation.
if Ekind (Ent) = E_Enumeration_Literal then if Ekind (Ent) = E_Enumeration_Literal then
Val := Enumeration_Pos (Ent); Val := Enumeration_Pos (Ent);
...@@ -3472,8 +3469,8 @@ package body Sem_Eval is ...@@ -3472,8 +3469,8 @@ package body Sem_Eval is
Val := Expr_Value (Constant_Value (Ent)); Val := Expr_Value (Constant_Value (Ent));
end if; end if;
-- An integer literal that was either in the source or created -- An integer literal that was either in the source or created as a
-- as a result of static evaluation. -- result of static evaluation.
elsif Kind = N_Integer_Literal then elsif Kind = N_Integer_Literal then
Val := Intval (N); Val := Intval (N);
...@@ -3585,8 +3582,8 @@ package body Sem_Eval is ...@@ -3585,8 +3582,8 @@ package body Sem_Eval is
return Ureal_0; return Ureal_0;
end if; end if;
-- If we fall through, we have a node that cannot be interpreted -- If we fall through, we have a node that cannot be interpreted as a
-- as a compile time constant. That is definitely an error. -- compile time constant. That is definitely an error.
raise Program_Error; raise Program_Error;
end Expr_Value_R; end Expr_Value_R;
...@@ -3650,8 +3647,8 @@ package body Sem_Eval is ...@@ -3650,8 +3647,8 @@ package body Sem_Eval is
Ent : Entity_Id; Ent : Entity_Id;
begin begin
-- If we are folding a named number, retain the entity in the -- If we are folding a named number, retain the entity in the literal,
-- literal, for ASIS use. -- for ASIS use.
if Is_Entity_Name (N) if Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Named_Integer and then Ekind (Entity (N)) = E_Named_Integer
...@@ -3704,8 +3701,8 @@ package body Sem_Eval is ...@@ -3704,8 +3701,8 @@ package body Sem_Eval is
Ent : Entity_Id; Ent : Entity_Id;
begin begin
-- If we are folding a named number, retain the entity in the -- If we are folding a named number, retain the entity in the literal,
-- literal, for ASIS use. -- for ASIS use.
if Is_Entity_Name (N) if Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Named_Real and then Ekind (Entity (N)) = E_Named_Real
...@@ -3941,8 +3938,8 @@ package body Sem_Eval is ...@@ -3941,8 +3938,8 @@ package body Sem_Eval is
LB_Known := Compile_Time_Known_Value (Lo); LB_Known := Compile_Time_Known_Value (Lo);
UB_Known := Compile_Time_Known_Value (Hi); UB_Known := Compile_Time_Known_Value (Hi);
-- Fixed point types should be considered as such only in -- Fixed point types should be considered as such only if flag
-- flag Fixed_Int is set to False. -- Fixed_Int is set to False.
if Is_Floating_Point_Type (Typ) if Is_Floating_Point_Type (Typ)
or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
...@@ -3950,24 +3947,16 @@ package body Sem_Eval is ...@@ -3950,24 +3947,16 @@ package body Sem_Eval is
then then
Valr := Expr_Value_R (N); Valr := Expr_Value_R (N);
if LB_Known and then Valr >= Expr_Value_R (Lo) return LB_Known and then Valr >= Expr_Value_R (Lo)
and then UB_Known and then Valr <= Expr_Value_R (Hi) and then
then UB_Known and then Valr <= Expr_Value_R (Hi);
return True;
else
return False;
end if;
else else
Val := Expr_Value (N); Val := Expr_Value (N);
if LB_Known and then Val >= Expr_Value (Lo) return LB_Known and then Val >= Expr_Value (Lo)
and then UB_Known and then Val <= Expr_Value (Hi) and then
then UB_Known and then Val <= Expr_Value (Hi);
return True;
else
return False;
end if;
end if; end if;
end; end;
end if; end if;
...@@ -4025,8 +4014,8 @@ package body Sem_Eval is ...@@ -4025,8 +4014,8 @@ package body Sem_Eval is
-- Is_OK_Static_Subtype -- -- Is_OK_Static_Subtype --
-------------------------- --------------------------
-- Determines if Typ is a static subtype as defined in (RM 4.9(26)) -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
-- where neither bound raises constraint error when evaluated. -- neither bound raises constraint error when evaluated.
function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
Base_T : constant Entity_Id := Base_Type (Typ); Base_T : constant Entity_Id := Base_Type (Typ);
...@@ -4068,8 +4057,8 @@ package body Sem_Eval is ...@@ -4068,8 +4057,8 @@ package body Sem_Eval is
return True; return True;
else else
-- Scalar_Range (Typ) might be an N_Subtype_Indication, so -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
-- use Get_Type_Low,High_Bound. -- Get_Type_{Low,High}_Bound.
return Is_OK_Static_Subtype (Anc_Subt) return Is_OK_Static_Subtype (Anc_Subt)
and then Is_OK_Static_Expression (Type_Low_Bound (Typ)) and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
...@@ -4143,9 +4132,9 @@ package body Sem_Eval is ...@@ -4143,9 +4132,9 @@ package body Sem_Eval is
LB_Known := Compile_Time_Known_Value (Lo); LB_Known := Compile_Time_Known_Value (Lo);
UB_Known := Compile_Time_Known_Value (Hi); UB_Known := Compile_Time_Known_Value (Hi);
-- Real types (note that fixed-point types are not treated -- Real types (note that fixed-point types are not treated as
-- as being of a real type if the flag Fixed_Int is set, -- being of a real type if the flag Fixed_Int is set, since in
-- since in that case they are regarded as integer types). -- that case they are regarded as integer types).
if Is_Floating_Point_Type (Typ) if Is_Floating_Point_Type (Typ)
or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
...@@ -4153,28 +4142,16 @@ package body Sem_Eval is ...@@ -4153,28 +4142,16 @@ package body Sem_Eval is
then then
Valr := Expr_Value_R (N); Valr := Expr_Value_R (N);
if LB_Known and then Valr < Expr_Value_R (Lo) then return (LB_Known and then Valr < Expr_Value_R (Lo))
return True; or else
(UB_Known and then Expr_Value_R (Hi) < Valr);
elsif UB_Known and then Expr_Value_R (Hi) < Valr then
return True;
else
return False;
end if;
else else
Val := Expr_Value (N); Val := Expr_Value (N);
if LB_Known and then Val < Expr_Value (Lo) then return (LB_Known and then Val < Expr_Value (Lo))
return True; or else
(UB_Known and then Expr_Value (Hi) < Val);
elsif UB_Known and then Expr_Value (Hi) < Val then
return True;
else
return False;
end if;
end if; end if;
end; end;
end if; end if;
...@@ -4302,10 +4279,9 @@ package body Sem_Eval is ...@@ -4302,10 +4279,9 @@ package body Sem_Eval is
begin begin
-- If we have the static expression case, then this is an illegality -- If we have the static expression case, then this is an illegality
-- in Ada 95 mode, except that in an instance, we never generate an -- in Ada 95 mode, except that in an instance, we never generate an
-- error (if the error is legitimate, it was already diagnosed in -- error (if the error is legitimate, it was already diagnosed in the
-- the template). The expression to compute the length of a packed -- template). The expression to compute the length of a packed array is
-- array is attached to the array type itself, and deserves a separate -- attached to the array type itself, and deserves a separate message.
-- message.
if Is_Static_Expression (N) if Is_Static_Expression (N)
and then not In_Instance and then not In_Instance
...@@ -4327,8 +4303,8 @@ package body Sem_Eval is ...@@ -4327,8 +4303,8 @@ package body Sem_Eval is
(N, "value not in range of}", CE_Range_Check_Failed); (N, "value not in range of}", CE_Range_Check_Failed);
end if; end if;
-- Here we generate a warning for the Ada 83 case, or when we are -- Here we generate a warning for the Ada 83 case, or when we are in an
-- in an instance, or when we have a non-static expression case. -- instance, or when we have a non-static expression case.
else else
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
...@@ -4344,22 +4320,22 @@ package body Sem_Eval is ...@@ -4344,22 +4320,22 @@ package body Sem_Eval is
Typ : constant Entity_Id := Etype (N); Typ : constant Entity_Id := Etype (N);
begin begin
-- If we want to raise CE in the condition of a raise_CE node -- If we want to raise CE in the condition of a N_Raise_CE node
-- we may as well get rid of the condition -- we may as well get rid of the condition.
if Present (Parent (N)) if Present (Parent (N))
and then Nkind (Parent (N)) = N_Raise_Constraint_Error and then Nkind (Parent (N)) = N_Raise_Constraint_Error
then then
Set_Condition (Parent (N), Empty); Set_Condition (Parent (N), Empty);
-- If the expression raising CE is a N_Raise_CE node, we can use -- If the expression raising CE is a N_Raise_CE node, we can use that
-- that one. We just preserve the type of the context -- one. We just preserve the type of the context.
elsif Nkind (Exp) = N_Raise_Constraint_Error then elsif Nkind (Exp) = N_Raise_Constraint_Error then
Rewrite (N, Exp); Rewrite (N, Exp);
Set_Etype (N, Typ); Set_Etype (N, Typ);
-- We have to build an explicit raise_ce node -- Else build an explcit N_Raise_CE
else else
Rewrite (N, Rewrite (N,
...@@ -4496,16 +4472,16 @@ package body Sem_Eval is ...@@ -4496,16 +4472,16 @@ package body Sem_Eval is
-- A constrained numeric subtype never matches an unconstrained -- A constrained numeric subtype never matches an unconstrained
-- subtype, i.e. both types must be constrained or unconstrained. -- subtype, i.e. both types must be constrained or unconstrained.
-- To understand the requirement for this test, see RM 4.9.1(1). -- To understand the requirement for this test, see RM 4.9.1(1). As
-- As is made clear in RM 3.5.4(11), type Integer, for example -- is made clear in RM 3.5.4(11), type Integer, for example is a
-- is a constrained subtype with constraint bounds matching the -- constrained subtype with constraint bounds matching the bounds of
-- bounds of its corresponding unconstrained base type. In this -- its corresponding unconstrained base type. In this situation,
-- situation, Integer and Integer'Base do not statically match, -- Integer and Integer'Base do not statically match, even though they
-- even though they have the same bounds. -- have the same bounds.
-- We only apply this test to types in Standard and types that -- We only apply this test to types in Standard and types that appear
-- appear in user programs. That way, we do not have to be -- in user programs. That way, we do not have to be too careful about
-- too careful about setting Is_Constrained right for itypes. -- setting Is_Constrained right for Itypes.
if Is_Numeric_Type (T1) if Is_Numeric_Type (T1)
and then (Is_Constrained (T1) /= Is_Constrained (T2)) and then (Is_Constrained (T1) /= Is_Constrained (T2))
...@@ -4516,9 +4492,9 @@ package body Sem_Eval is ...@@ -4516,9 +4492,9 @@ package body Sem_Eval is
then then
return False; return False;
-- A generic scalar type does not statically match its base -- A generic scalar type does not statically match its base type
-- type (AI-311). In this case we make sure that the formals, -- (AI-311). In this case we make sure that the formals, which are
-- which are first subtypes of their bases, are constrained. -- first subtypes of their bases, are constrained.
elsif Is_Generic_Type (T1) elsif Is_Generic_Type (T1)
and then Is_Generic_Type (T2) and then Is_Generic_Type (T2)
...@@ -4527,8 +4503,8 @@ package body Sem_Eval is ...@@ -4527,8 +4503,8 @@ package body Sem_Eval is
return False; return False;
end if; end if;
-- If there was an error in either range, then just assume -- If there was an error in either range, then just assume the types
-- the types statically match to avoid further junk errors -- statically match to avoid further junk errors.
if Error_Posted (Scalar_Range (T1)) if Error_Posted (Scalar_Range (T1))
or else or else
...@@ -4559,8 +4535,8 @@ package body Sem_Eval is ...@@ -4559,8 +4535,8 @@ package body Sem_Eval is
then then
return False; return False;
-- If either type has constraint error bounds, then say -- If either type has constraint error bounds, then say that
-- that they match to avoid junk cascaded errors here. -- they match to avoid junk cascaded errors here.
elsif not Is_OK_Static_Subtype (T1) elsif not Is_OK_Static_Subtype (T1)
or else not Is_OK_Static_Subtype (T2) or else not Is_OK_Static_Subtype (T2)
...@@ -4670,11 +4646,11 @@ package body Sem_Eval is ...@@ -4670,11 +4646,11 @@ package body Sem_Eval is
return True; return True;
-- A definite type does not match an indefinite or classwide type -- A definite type does not match an indefinite or classwide type.
-- However, a generic type with unknown discriminants may be -- However, a generic type with unknown discriminants may be
-- instantiated with a type with no discriminants, and conformance -- instantiated with a type with no discriminants, and conformance
-- checking on an inherited operation may compare the actual with -- checking on an inherited operation may compare the actual with the
-- the subtype that renames it in the instance. -- subtype that renames it in the instance.
elsif elsif
Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2) Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
...@@ -4686,16 +4662,15 @@ package body Sem_Eval is ...@@ -4686,16 +4662,15 @@ package body Sem_Eval is
elsif Is_Array_Type (T1) then elsif Is_Array_Type (T1) then
-- If either subtype is unconstrained then both must be, -- If either subtype is unconstrained then both must be, and if both
-- and if both are unconstrained then no further checking -- are unconstrained then no further checking is neede.
-- is needed.
if not Is_Constrained (T1) or else not Is_Constrained (T2) then if not Is_Constrained (T1) or else not Is_Constrained (T2) then
return not (Is_Constrained (T1) or else Is_Constrained (T2)); return not (Is_Constrained (T1) or else Is_Constrained (T2));
end if; end if;
-- Both subtypes are constrained, so check that the index -- Both subtypes are constrained, so check that the index subtypes
-- subtypes statically match. -- statically match.
declare declare
Index1 : Node_Id := First_Index (T1); Index1 : Node_Id := First_Index (T1);
...@@ -4846,8 +4821,8 @@ package body Sem_Eval is ...@@ -4846,8 +4821,8 @@ package body Sem_Eval is
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
return; return;
-- If left operand raises constraint error, then replace node N with -- If left operand raises constraint error, then replace node N with the
-- the raise constraint error node, and we are obviously not foldable. -- Raise_Constraint_Error node, and we are obviously not foldable.
-- Is_Static_Expression is set from the two operands in the normal way, -- Is_Static_Expression is set from the two operands in the normal way,
-- and we check the right operand if it is in a non-static context. -- and we check the right operand if it is in a non-static context.
...@@ -4860,9 +4835,9 @@ package body Sem_Eval is ...@@ -4860,9 +4835,9 @@ package body Sem_Eval is
Set_Is_Static_Expression (N, Rstat); Set_Is_Static_Expression (N, Rstat);
return; return;
-- Similar processing for the case of the right operand. Note that -- Similar processing for the case of the right operand. Note that we
-- we don't use this routine for the short-circuit case, so we do -- don't use this routine for the short-circuit case, so we do not have
-- not have to worry about that special case here. -- to worry about that special case here.
elsif Raises_Constraint_Error (Op2) then elsif Raises_Constraint_Error (Op2) then
if not Rstat then if not Rstat then
...@@ -4882,7 +4857,7 @@ package body Sem_Eval is ...@@ -4882,7 +4857,7 @@ package body Sem_Eval is
return; return;
-- If result is not static, then check non-static contexts on operands -- If result is not static, then check non-static contexts on operands
-- since one of them may be static and the other one may not be static -- since one of them may be static and the other one may not be static.
elsif not Rstat then elsif not Rstat then
Check_Non_Static_Context (Op1); Check_Non_Static_Context (Op1);
...@@ -4891,8 +4866,8 @@ package body Sem_Eval is ...@@ -4891,8 +4866,8 @@ package body Sem_Eval is
and then Compile_Time_Known_Value (Op2); and then Compile_Time_Known_Value (Op2);
return; return;
-- Else result is static and foldable. Both operands are static, -- Else result is static and foldable. Both operands are static, and
-- and neither raises constraint error, so we can definitely fold. -- neither raises constraint error, so we can definitely fold.
else else
Set_Is_Static_Expression (N); Set_Is_Static_Expression (N);
...@@ -4923,8 +4898,8 @@ package body Sem_Eval is ...@@ -4923,8 +4898,8 @@ package body Sem_Eval is
E : Entity_Id; E : Entity_Id;
procedure Why_Not_Static_List (L : List_Id); procedure Why_Not_Static_List (L : List_Id);
-- A version that can be called on a list of expressions. Finds -- A version that can be called on a list of expressions. Finds all
-- all non-static violations in any element of the list. -- non-static violations in any element of the list.
------------------------- -------------------------
-- Why_Not_Static_List -- -- Why_Not_Static_List --
...@@ -4946,8 +4921,8 @@ package body Sem_Eval is ...@@ -4946,8 +4921,8 @@ package body Sem_Eval is
-- Start of processing for Why_Not_Static -- Start of processing for Why_Not_Static
begin begin
-- If in ACATS mode (debug flag 2), then suppress all these -- If in ACATS mode (debug flag 2), then suppress all these messages,
-- messages, this avoids massive updates to the ACATS base line. -- this avoids massive updates to the ACATS base line.
if Debug_Flag_2 then if Debug_Flag_2 then
return; return;
...@@ -5071,8 +5046,8 @@ package body Sem_Eval is ...@@ -5071,8 +5046,8 @@ package body Sem_Eval is
return; return;
-- Special case generic types, since again this is a common -- Special case generic types, since again this is a common source
-- source of confusion. -- of confusion.
elsif Is_Generic_Actual_Type (E) elsif Is_Generic_Actual_Type (E)
or else or else
......
gcc/ada/sem_intr.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -54,7 +54,7 @@ package body Sem_Intr is ...@@ -54,7 +54,7 @@ package body Sem_Intr is
procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id); procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id);
-- Check that operator is one of the binary arithmetic operators, and -- Check that operator is one of the binary arithmetic operators, and
-- that the types involved both have underlying integer types.. -- that the types involved both have underlying integer types.
procedure Check_Shift (E : Entity_Id; N : Node_Id); procedure Check_Shift (E : Entity_Id; N : Node_Id);
-- Check intrinsic shift subprogram, the two arguments are the same -- Check intrinsic shift subprogram, the two arguments are the same
......
gcc/ada/sem_type.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -2554,9 +2554,9 @@ package body Sem_Type is ...@@ -2554,9 +2554,9 @@ package body Sem_Type is
BT1 := Base_Type (T1); BT1 := Base_Type (T1);
BT2 := Base_Type (T2); BT2 := Base_Type (T2);
-- Handle underlying view of records with unknown discriminants -- Handle underlying view of records with unknown discriminants using
-- using the original entity that motivated the construction of -- the original entity that motivated the construction of this
-- this underlying record view (see Build_Derived_Private_Type). -- underlying record view (see Build_Derived_Private_Type).
if Is_Underlying_Record_View (BT1) then if Is_Underlying_Record_View (BT1) then
BT1 := Underlying_Record_View (BT1); BT1 := Underlying_Record_View (BT1);
...@@ -2569,12 +2569,20 @@ package body Sem_Type is ...@@ -2569,12 +2569,20 @@ package body Sem_Type is
if BT1 = BT2 then if BT1 = BT2 then
return True; return True;
-- The predicate must look past privacy
elsif Is_Private_Type (T1) elsif Is_Private_Type (T1)
and then Present (Full_View (T1)) and then Present (Full_View (T1))
and then BT2 = Base_Type (Full_View (T1)) and then BT2 = Base_Type (Full_View (T1))
then then
return True; return True;
elsif Is_Private_Type (T2)
and then Present (Full_View (T2))
and then BT1 = Base_Type (Full_View (T2))
then
return True;
else else
Par := Etype (BT2); Par := Etype (BT2);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment