This patch fixes an infinite loop in GNAT when dynamic elaboration checks are
generated for an instantiation of a generic function whose type is obtained
from a formal package.
The following must compile quietly:
gcc -c -gnatE main.adb
---
with Ada.Text_IO; use Ada.Text_IO;
with Optional_Values;
with Optional_Values_Map;
procedure Main is
package Optional_Floats is new Optional_Values (T => Float);
package Optional_Integers is new Optional_Values (T => Integer);
function Int_Of_Float (X : Float) return Integer is
begin
return Integer (X);
end Int_Of_Float;
function Map is new Optional_Values_Map
(Input_Type => Float,
Output_Type => Integer,
Optional_Inputs => Optional_Floats,
Optional_Outputs => Optional_Integers,
Map => Int_Of_Float);
Pi : constant := 3.1415;
Optional_Three : constant Optional_Integers.Optional_Value_Type :=
Map (Optional_Floats.Of_Value (Value => Pi));
begin
if Optional_Integers.Has_Value (Optional_Three) then
declare
Three : constant Integer :=
Optional_Integers.Get_Value (Optional_Three);
begin
Put_Line ("Result =" & Three'Img);
end;
end if;
end Main;
---
package body Optional_Values is
function Of_Value (Value : T) return Optional_Value_Type is
((Optional => (Has_Value => True, Value => Value)));
function Get_Value (Optional_Value : Optional_Value_Type) return T is
(Optional_Value.Optional.Value);
end Optional_Values;
---
generic
type T is private;
package Optional_Values is
pragma Pure;
type Optional_Value_Type is private;
Null_Optional_Value : constant Optional_Value_Type;
function Of_Value (Value : T) return Optional_Value_Type;
function Has_Value (Optional_Value : Optional_Value_Type) return Boolean;
function Get_Value (Optional_Value : Optional_Value_Type) return T
with Pre => Has_Value (Optional_Value);
private
type Internal_Type (Has_Value : Boolean := False) is record
case Has_Value is
when True =>
Value : T;
when False =>
null;
end case;
end record;
type Optional_Value_Type is record
Optional : Internal_Type;
end record;
Null_Optional_Value : constant Optional_Value_Type
:= (Optional => (Has_Value => False));
function Has_Value (Optional_Value : Optional_Value_Type) return Boolean is
(Optional_Value.Optional.Has_Value);
end Optional_Values;
---
function Optional_Values_Map
(Optional_Input : Optional_Inputs.Optional_Value_Type)
return Optional_Outputs.Optional_Value_Type
is
use Optional_Inputs;
begin
if Has_Value (Optional_Input) then
return Optional_Outputs.Of_Value (Map (Get_Value (Optional_Input)));
end if;
return Optional_Outputs.Null_Optional_Value;
end Optional_Values_Map;
---
with Optional_Values;
generic
type Input_Type is private;
type Output_Type is private;
with package Optional_Inputs is new Optional_Values (T => Input_Type);
with package Optional_Outputs is new Optional_Values (T => Output_Type);
with function Map (Input : Input_Type) return Output_Type;
function Optional_Values_Map
(Optional_Input : Optional_Inputs.Optional_Value_Type)
return Optional_Outputs.Optional_Value_Type;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-10-23 Ed Schonberg <schonb...@adacore.com>
* sem_attr.adb (Analyze_Attribute): The prefix of attribute Elaborated
does not require freezing, in particular if it denotes a generic
function.
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 216574)
+++ sem_attr.adb (working copy)
@@ -11164,8 +11164,17 @@
-- Normally the Freezing is done by Resolve but sometimes the Prefix
-- is not resolved, in which case the freezing must be done now.
- Freeze_Expression (P);
+ -- For an elaboration check on a subprogram, we do not freeze its type.
+ -- It may be declared in an unrelated scope, in particular in the case
+ -- of a generic function whose type may remain unelaborated.
+ if Attr_Id = Attribute_Elaborated then
+ null;
+
+ else
+ Freeze_Expression (P);
+ end if;
+
-- Finally perform static evaluation on the attribute reference
Analyze_Dimension (N);
