-- --
-- B o d y --
-- --
--- $Revision: 1.304 $
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Nlists; use Nlists;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
-- or other invalid values do NOT cause a Constraint_Error to be raised.
procedure Expand_Fpt_Attribute
- (N : Node_Id;
- Rtp : Entity_Id;
+ (N : Node_Id;
+ Rtp : Entity_Id;
+ Nam : Name_Id;
Args : List_Id);
-- This procedure expands a call to a floating-point attribute function.
-- N is the attribute reference node, and Args is a list of arguments to
-- be passed to the function call. Rtp is the root type of the floating
-- point type involved (used to select the proper generic instantiation
- -- of the package containing the attribute routines).
+ -- of the package containing the attribute routines). The Nam argument
+ -- is the attribute processing routine to be called. This is normally
+ -- the same as the attribute name, except in the Unaligned_Valid case.
procedure Expand_Fpt_Attribute_R (N : Node_Id);
-- This procedure expands a call to a floating-point attribute function
- -- that takes a single floating-point argument.
+ -- that takes a single floating-point argument. The function to be called
+ -- is always the same as the attribute name.
procedure Expand_Fpt_Attribute_RI (N : Node_Id);
-- This procedure expands a call to a floating-point attribute function
- -- that takes one floating-point argument and one integer argument.
+ -- that takes one floating-point argument and one integer argument. The
+ -- function to be called is always the same as the attribute name.
procedure Expand_Fpt_Attribute_RR (N : Node_Id);
-- This procedure expands a call to a floating-point attribute function
- -- that takes two floating-point arguments.
+ -- that takes two floating-point arguments. The function to be called
+ -- is always the same as the attribute name.
procedure Expand_Pred_Succ (N : Node_Id);
-- Handles expansion of Pred or Succ attributes for case of non-real
function Find_Inherited_TSS
(Typ : Entity_Id;
- Nam : Name_Id) return Entity_Id;
+ Nam : TSS_Name_Type) return Entity_Id;
+ -- Returns the TSS of name Nam of Typ, or of its closest ancestor defining
+ -- such a TSS. Empty is returned is neither Typ nor any of its ancestors
+ -- have such a TSS.
+
+ function Find_Stream_Subprogram
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Entity_Id;
+ -- Returns the stream-oriented subprogram attribute for Typ. For tagged
+ -- types, the corresponding primitive operation is looked up, else the
+ -- appropriate TSS from the type itself, or from its closest ancestor
+ -- defining it, is returned. In both cases, inheritance of representation
+ -- aspects is thus taken into account.
function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
-- Utility for array attributes, returns true on packed constrained
procedure Expand_Fpt_Attribute
(N : Node_Id;
Rtp : Entity_Id;
+ Nam : Name_Id;
Args : List_Id)
is
Loc : constant Source_Ptr := Sloc (N);
begin
-- The function name is the selected component Fat_xxx.yyy where xxx
- -- is the floating-point root type, and yyy is the attribute name
+ -- is the floating-point root type, and yyy is the argument Nam.
-- Note: it would be more usual to have separate RE entries for each
-- of the entities in the Fat packages, but first they have identical
Fnm :=
Make_Selected_Component (Loc,
Prefix => New_Reference_To (RTE (Pkg), Loc),
- Selector_Name => Make_Identifier (Loc, Attribute_Name (N)));
+ Selector_Name => Make_Identifier (Loc, Nam));
-- The generated call is given the provided set of parameters, and then
-- wrapped in a conversion which converts the result to the target type
Parameter_Associations => Args)));
Analyze_And_Resolve (N, Typ);
-
end Expand_Fpt_Attribute;
----------------------------
Rtp : constant Entity_Id := Root_Type (Etype (E1));
begin
- Expand_Fpt_Attribute (N, Rtp, New_List (
- Unchecked_Convert_To (Rtp, Relocate_Node (E1))));
+ Expand_Fpt_Attribute
+ (N, Rtp, Attribute_Name (N),
+ New_List (Unchecked_Convert_To (Rtp, Relocate_Node (E1))));
end Expand_Fpt_Attribute_R;
-----------------------------
E2 : constant Node_Id := Next (E1);
begin
- Expand_Fpt_Attribute (N, Rtp, New_List (
- Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
- Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
+ Expand_Fpt_Attribute
+ (N, Rtp, Attribute_Name (N),
+ New_List (
+ Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
+ Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
end Expand_Fpt_Attribute_RI;
-----------------------------
E2 : constant Node_Id := Next (E1);
begin
- Expand_Fpt_Attribute (N, Rtp, New_List (
- Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
- Unchecked_Convert_To (Rtp, Relocate_Node (E2))));
+ Expand_Fpt_Attribute
+ (N, Rtp, Attribute_Name (N),
+ New_List (
+ Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
+ Unchecked_Convert_To (Rtp, Relocate_Node (E2))));
end Expand_Fpt_Attribute_RR;
----------------------------------
procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
Item : constant Node_Id := Next (First (Exprs));
- Formal_Typ : constant Entity_Id :=
- Etype (Next_Formal (First_Formal (Pname)));
+ Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
+ Formal_Typ : constant Entity_Id := Etype (Formal);
+ Is_Written : constant Boolean := (Ekind (Formal) /= E_In_Parameter);
begin
- -- We have to worry about the type of the second argument
+ -- The expansion depends on Item, the second actual, which is
+ -- the object being streamed in or out.
+
+ -- If the item is a component of a packed array type, and
+ -- a conversion is needed on exit, we introduce a temporary to
+ -- hold the value, because otherwise the packed reference will
+ -- not be properly expanded.
+
+ if Nkind (Item) = N_Indexed_Component
+ and then Is_Packed (Base_Type (Etype (Prefix (Item))))
+ and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
+ and then Is_Written
+ then
+ declare
+ Temp : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('V'));
+ Decl : Node_Id;
+ Assn : Node_Id;
+
+ begin
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition =>
+ New_Occurrence_Of (Formal_Typ, Loc));
+ Set_Etype (Temp, Formal_Typ);
+
+ Assn :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Copy_Tree (Item),
+ Expression =>
+ Unchecked_Convert_To
+ (Etype (Item), New_Occurrence_Of (Temp, Loc)));
+
+ Rewrite (Item, New_Occurrence_Of (Temp, Loc));
+ Insert_Actions (N,
+ New_List (
+ Decl,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Pname, Loc),
+ Parameter_Associations => Exprs),
+ Assn));
+
+ Rewrite (N, Make_Null_Statement (Loc));
+ return;
+ end;
+ end if;
-- For the class-wide dispatching cases, and for cases in which
-- the base type of the second argument matches the base type of
- -- the corresponding formal parameter, we are all set, and can use
- -- the argument unchanged.
+ -- the corresponding formal parameter (that is to say the stream
+ -- operation is not inherited), we are all set, and can use the
+ -- argument unchanged.
-- For all other cases we do an unchecked conversion of the second
-- parameter to the type of the formal of the procedure we are
-- to the root type as required in elementary type case.
if not Is_Class_Wide_Type (Entity (Pref))
+ and then not Is_Class_Wide_Type (Etype (Item))
and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
then
Rewrite (Item,
declare
Agg : Node_Id;
Sub : Entity_Id;
- E_T : constant Entity_Id := Equivalent_Type (Typ);
+ E_T : constant Entity_Id := Equivalent_Type (Btyp);
Acc : constant Entity_Id :=
Etype (Next_Component (First_Component (E_T)));
Obj_Ref : Node_Id;
Rewrite (N, Agg);
- Analyze_And_Resolve (N, Equivalent_Type (Typ));
+ Analyze_And_Resolve (N, E_T);
-- For subsequent analysis, the node must retain its type.
-- The backend will replace it with the equivalent type where
end Address;
---------------
+ -- Alignment --
+ ---------------
+
+ when Attribute_Alignment => Alignment : declare
+ Ptyp : constant Entity_Id := Etype (Pref);
+ New_Node : Node_Id;
+
+ begin
+ -- For class-wide types, X'Class'Alignment is transformed into a
+ -- direct reference to the Alignment of the class type, so that the
+ -- back end does not have to deal with the X'Class'Alignment
+ -- reference.
+
+ if Is_Entity_Name (Pref)
+ and then Is_Class_Wide_Type (Entity (Pref))
+ then
+ Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
+ return;
+
+ -- For x'Alignment applied to an object of a class wide type,
+ -- transform X'Alignment into a call to the predefined primitive
+ -- operation _Alignment applied to X.
+
+ elsif Is_Class_Wide_Type (Ptyp) then
+ New_Node :=
+ Make_Function_Call (Loc,
+ Name => New_Reference_To
+ (Find_Prim_Op (Ptyp, Name_uAlignment), Loc),
+ Parameter_Associations => New_List (Pref));
+
+ if Typ /= Standard_Integer then
+
+ -- The context is a specific integer type with which the
+ -- original attribute was compatible. The function has a
+ -- specific type as well, so to preserve the compatibility
+ -- we must convert explicitly.
+
+ New_Node := Convert_To (Typ, New_Node);
+ end if;
+
+ Rewrite (N, New_Node);
+ Analyze_And_Resolve (N, Typ);
+ return;
+
+ -- For all other cases, we just have to deal with the case of
+ -- the fact that the result can be universal.
+
+ else
+ Apply_Universal_Integer_Attribute_Checks (N);
+ end if;
+ end Alignment;
+
+ ---------------
-- AST_Entry --
---------------
if Pent = Standard_Standard
or else Pent = Standard_ASCII
then
- Name_Buffer (1 .. Library_Version'Length) := Library_Version;
- Name_Len := Library_Version'Length;
+ Name_Buffer (1 .. Verbose_Library_Version'Length) :=
+ Verbose_Library_Version;
+ Name_Len := Verbose_Library_Version'Length;
Rewrite (N,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
-- Task_Entry_Caller or the Protected_Entry_Caller function.
when Attribute_Caller => Caller : declare
- Id_Kind : Entity_Id := RTE (RO_AT_Task_ID);
- Ent : Entity_Id := Entity (Pref);
- Conctype : Entity_Id := Scope (Ent);
- Nest_Depth : Integer := 0;
+ Id_Kind : constant Entity_Id := RTE (RO_AT_Task_ID);
+ Ent : constant Entity_Id := Entity (Pref);
+ Conctype : constant Entity_Id := Scope (Ent);
+ Nest_Depth : Integer := 0;
Name : Node_Id;
S : Entity_Id;
if Is_Protected_Type (Conctype) then
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Conctype) > 1
then
Name :=
begin
-- Reference to a parameter where the value is passed as an extra
-- actual, corresponding to the extra formal referenced by the
- -- Extra_Constrained field of the corresponding formal.
+ -- Extra_Constrained field of the corresponding formal. If this
+ -- is an entry in-parameter, it is replaced by a constant renaming
+ -- for which Extra_Constrained is never created.
if Present (Formal_Ent)
+ and then Ekind (Formal_Ent) /= E_Constant
and then Present (Extra_Constrained (Formal_Ent))
then
Rewrite (N,
-- within the generic template would have been illegal.
else
- declare
- UT : Entity_Id := Underlying_Type (Ent);
-
- begin
- if Is_Composite_Type (UT) then
- Res := Is_Constrained (Ent);
- else
- Res := True;
- end if;
- end;
+ if Is_Composite_Type (Underlying_Type (Ent)) then
+ Res := Is_Constrained (Ent);
+ else
+ Res := True;
+ end if;
end if;
-- If the prefix is not a variable or is aliased, then
if Is_Protected_Type (Conctyp) then
if Abort_Allowed
- or else Restrictions (No_Entry_Queue) = False
+ or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Conctyp) > 1
then
Name := New_Reference_To (RTE (RE_Protected_Count), Loc);
Rewrite (N,
Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref))));
+ -- If this is a renaming of a literal, recover the representation
+ -- of the original.
+
+ elsif Ekind (Entity (Pref)) = E_Constant
+ and then Present (Renamed_Object (Entity (Pref)))
+ and then
+ Ekind (Entity (Renamed_Object (Entity (Pref))))
+ = E_Enumeration_Literal
+ then
+ Rewrite (N,
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (Entity (Renamed_Object (Entity (Pref))))));
+
-- X'Enum_Rep where X is an object does a direct unchecked conversion
-- of the object value, as described for the type case above.
Expression => Relocate_Node (First (Exprs))));
Set_Etype (N, Entity (Pref));
Set_Analyzed (N);
+
+ -- Note: it might appear that a properly analyzed unchecked conversion
+ -- would be just fine here, but that's not the case, since the full
+ -- range checks performed by the following call are critical!
+
Apply_Type_Conversion_Checks (N);
end Fixed_Value;
-- If there is a TSS for Input, just call it
- Fname := Find_Inherited_TSS (P_Type, Name_uInput);
+ Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
if Present (Fname) then
null;
-- A special case arises if we have a defined _Read routine,
-- since in this case we are required to call this routine.
- if Present (TSS (B_Type, Name_uRead)) then
+ if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
Build_Record_Or_Elementary_Input_Function
(Loc, U_Type, Decl, Fname);
Insert_Action (N, Decl);
-- Now we need to get the entity for the call, and construct
-- a function call node, where we preset a reference to Dnn
-- as the controlling argument (doing an unchecked
- -- conversion to the tagged type to make it look like
- -- a real tagged object).
+ -- conversion to the classwide tagged type to make it
+ -- look like a real tagged object).
- Fname := Find_Prim_Op (Rtyp, Name_uInput);
- Cntrl := Unchecked_Convert_To (Rtyp,
+ Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
+ Cntrl := Unchecked_Convert_To (P_Type,
New_Occurrence_Of (Dnn, Loc));
- Set_Etype (Cntrl, Rtyp);
+ Set_Etype (Cntrl, P_Type);
Set_Parent (Cntrl, N);
end;
-- For tagged types, use the primitive Input function
elsif Is_Tagged_Type (U_Type) then
- Fname := Find_Prim_Op (U_Type, Name_uInput);
+ Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
-- All other record type cases, including protected records.
-- The latter only arise for expander generated code for
Expression => Relocate_Node (First (Exprs))));
Set_Etype (N, Entity (Pref));
Set_Analyzed (N);
+
+ -- Note: it might appear that a properly analyzed unchecked conversion
+ -- would be just fine here, but that's not the case, since the full
+ -- range checks performed by the following call are critical!
+
Apply_Type_Conversion_Checks (N);
end Integer_Value;
Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Pref),
+ Prefix =>
+ Duplicate_Subexpr_No_Checks (Pref),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, Xnum)))))),
Attribute_Name => Name_Pos,
Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Pref),
+ Prefix =>
+ Duplicate_Subexpr_No_Checks (Pref),
Attribute_Name => Name_First,
Expressions =>
New_Copy_List (Exprs)))))))));
when Attribute_Output => Output : declare
P_Type : constant Entity_Id := Entity (Pref);
- B_Type : constant Entity_Id := Base_Type (P_Type);
U_Type : constant Entity_Id := Underlying_Type (P_Type);
Pname : Entity_Id;
Decl : Node_Id;
-- If TSS for Output is present, just call it
- Pname := Find_Inherited_TSS (P_Type, Name_uOutput);
+ Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
if Present (Pname) then
null;
-- A special case arises if we have a defined _Write routine,
-- since in this case we are required to call this routine.
- if Present (TSS (B_Type, Name_uWrite)) then
+ if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
Build_Record_Or_Elementary_Output_Procedure
(Loc, U_Type, Decl, Pname);
Insert_Action (N, Decl);
Attribute_Name => Name_Tag))))));
end Tag_Write;
- Pname := Find_Prim_Op (U_Type, Name_uOutput);
+ Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
-- Tagged type case, use the primitive Output function
elsif Is_Tagged_Type (U_Type) then
- Pname := Find_Prim_Op (U_Type, Name_uOutput);
+ Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
-- All other record type cases, including protected records.
-- The latter only arise for expander generated code for
-- generate a call to the _Rep_To_Pos function created when the
-- type was frozen. The call has the form
- -- _rep_to_pos (expr, True)
+ -- _rep_to_pos (expr, flag)
- -- The parameter True causes Program_Error to be raised if the
- -- expression has an invalid representation.
+ -- The parameter flag is True if range checks are enabled, causing
+ -- Program_Error to be raised if the expression has an invalid
+ -- representation, and False if range checks are suppressed.
-- For integer types, Pos is equivalent to a simple integer
-- conversion and we rewrite it as such
-- Non-standard enumeration type (generate call)
if Present (Enum_Pos_To_Rep (Etyp)) then
- Append_To (Exprs, New_Occurrence_Of (Standard_True, Loc));
-
+ Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
Name =>
- New_Reference_To (TSS (Etyp, Name_uRep_To_Pos), Loc),
+ New_Reference_To (TSS (Etyp, TSS_Rep_To_Pos), Loc),
Parameter_Associations => Exprs)));
Analyze_And_Resolve (N, Typ);
-- Pos_To_Rep (Rep_To_Pos (x) - 1)
+ -- If the representation is contiguous, we compute instead
+ -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
+
if Is_Enumeration_Type (Ptyp)
and then Present (Enum_Pos_To_Rep (Ptyp))
then
- -- Add Boolean parameter True, to request program errror if
- -- we have a bad representation on our hands.
+ if Has_Contiguous_Rep (Ptyp) then
+ Rewrite (N,
+ Unchecked_Convert_To (Ptyp,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (First_Literal (Ptyp))),
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To
+ (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
+
+ Parameter_Associations =>
+ New_List (
+ Unchecked_Convert_To (Ptyp,
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To (Standard_Integer,
+ Relocate_Node (First (Exprs))),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, 1))),
+ Rep_To_Pos_Flag (Ptyp, Loc))))));
- Append_To (Exprs, New_Occurrence_Of (Standard_True, Loc));
+ else
+ -- Add Boolean parameter True, to request program errror if
+ -- we have a bad representation on our hands. If checks are
+ -- suppressed, then add False instead
- Rewrite (N,
- Make_Indexed_Component (Loc,
- Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
- Expressions => New_List (
- Make_Op_Subtract (Loc,
+ Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
+ Rewrite (N,
+ Make_Indexed_Component (Loc,
+ Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
+ Expressions => New_List (
+ Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Function_Call (Loc,
Name =>
- New_Reference_To (TSS (Ptyp, Name_uRep_To_Pos), Loc),
- Parameter_Associations => Exprs),
+ New_Reference_To (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
+ Parameter_Associations => Exprs),
Right_Opnd => Make_Integer_Literal (Loc, 1)))));
+ end if;
Analyze_And_Resolve (N, Typ);
-- The simple case, if there is a TSS for Read, just call it
- Pname := Find_Inherited_TSS (P_Type, Name_uRead);
+ Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
if Present (Pname) then
null;
Rewrite (N,
Make_Assignment_Statement (Loc,
- Name => Lhs,
+ Name => Lhs,
Expression => Rhs));
Set_Assignment_OK (Lhs);
Analyze (N);
-- this will dispatch in the class-wide case which is what we want
elsif Is_Tagged_Type (U_Type) then
- Pname := Find_Prim_Op (U_Type, Name_uRead);
+ Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
-- All other record type cases, including protected records.
-- The latter only arise for expander generated code for
declare
Ptyp : constant Entity_Id := Etype (Pref);
- New_Node : Node_Id;
Siz : Uint;
+ New_Node : Node_Id;
begin
-- Processing for VADS_Size case. Note that this processing removes
end if;
end if;
- -- For class-wide types, transform X'Size into a call to
- -- the primitive operation _Size
+ -- For class-wide types, X'Class'Size is transformed into a
+ -- direct reference to the Size of the class type, so that gigi
+ -- does not have to deal with the X'Class'Size reference.
+
+ if Is_Entity_Name (Pref)
+ and then Is_Class_Wide_Type (Entity (Pref))
+ then
+ Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
+ return;
+
+ -- For x'Size applied to an object of a class wide type, transform
+ -- X'Size into a call to the primitive operation _Size applied to X.
- if Is_Class_Wide_Type (Ptyp) then
+ elsif Is_Class_Wide_Type (Ptyp) then
New_Node :=
Make_Function_Call (Loc,
Name => New_Reference_To
Rewrite (N,
OK_Convert_To (Typ,
Make_Function_Call (Loc,
- Name => New_Reference_To (Find_Prim_Op (Etype (
- Associated_Storage_Pool (Root_Type (Ptyp))),
- Attribute_Name (N)), Loc),
+ Name =>
+ New_Reference_To
+ (Find_Prim_Op
+ (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
+ Attribute_Name (N)),
+ Loc),
Parameter_Associations => New_List (New_Reference_To (
Associated_Storage_Pool (Root_Type (Ptyp)), Loc)))));
-- Pos_To_Rep (Rep_To_Pos (x) + 1)
+ -- If the representation is contiguous, we compute instead
+ -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
+
if Is_Enumeration_Type (Ptyp)
and then Present (Enum_Pos_To_Rep (Ptyp))
then
- -- Add Boolean parameter True, to request program errror if
- -- we have a bad representation on our hands.
-
- Append_To (Exprs, New_Occurrence_Of (Standard_True, Loc));
+ if Has_Contiguous_Rep (Ptyp) then
+ Rewrite (N,
+ Unchecked_Convert_To (Ptyp,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (First_Literal (Ptyp))),
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To
+ (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
+
+ Parameter_Associations =>
+ New_List (
+ Unchecked_Convert_To (Ptyp,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To (Standard_Integer,
+ Relocate_Node (First (Exprs))),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, 1))),
+ Rep_To_Pos_Flag (Ptyp, Loc))))));
+ else
+ -- Add Boolean parameter True, to request program errror if
+ -- we have a bad representation on our hands. Add False if
+ -- checks are suppressed.
- Rewrite (N,
- Make_Indexed_Component (Loc,
- Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
- Expressions => New_List (
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (TSS (Ptyp, Name_uRep_To_Pos), Loc),
- Parameter_Associations => Exprs),
- Right_Opnd => Make_Integer_Literal (Loc, 1)))));
+ Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
+ Rewrite (N,
+ Make_Indexed_Component (Loc,
+ Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
+ Expressions => New_List (
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To
+ (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
+ Parameter_Associations => Exprs),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)))));
+ end if;
Analyze_And_Resolve (N, Typ);
Ttyp := Underlying_Type (Ttyp);
if Prefix_Is_Type then
- Rewrite (N,
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Access_Disp_Table (Ttyp), Loc)));
+
+ -- For JGNAT we leave the type attribute unexpanded because
+ -- there's not a dispatching table to reference.
+
+ if not Java_VM then
+ Rewrite (N,
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (Access_Disp_Table (Ttyp), Loc)));
+ Analyze_And_Resolve (N, RTE (RE_Tag));
+ end if;
else
Rewrite (N,
Prefix => Relocate_Node (Pref),
Selector_Name =>
New_Reference_To (Tag_Component (Ttyp), Loc)));
+ Analyze_And_Resolve (N, RTE (RE_Tag));
end if;
-
- Analyze_And_Resolve (N, RTE (RE_Tag));
end Tag;
----------------
if Is_Enumeration_Type (Etyp)
and then Present (Enum_Pos_To_Rep (Etyp))
then
- Rewrite (N,
- Make_Indexed_Component (Loc,
- Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc),
- Expressions => New_List (
- Convert_To (Standard_Integer,
- Relocate_Node (First (Exprs))))));
+ if Has_Contiguous_Rep (Etyp) then
+ declare
+ Rep_Node : constant Node_Id :=
+ Unchecked_Convert_To (Etyp,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (First_Literal (Etyp))),
+ Right_Opnd =>
+ (Convert_To (Standard_Integer,
+ Relocate_Node (First (Exprs))))));
+
+ begin
+ Rewrite (N,
+ Unchecked_Convert_To (Etyp,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (First_Literal (Etyp))),
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To
+ (TSS (Etyp, TSS_Rep_To_Pos), Loc),
+ Parameter_Associations => New_List (
+ Rep_Node,
+ Rep_To_Pos_Flag (Etyp, Loc))))));
+ end;
+
+ else
+ Rewrite (N,
+ Make_Indexed_Component (Loc,
+ Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc),
+ Expressions => New_List (
+ Convert_To (Standard_Integer,
+ Relocate_Node (First (Exprs))))));
+ end if;
Analyze_And_Resolve (N, Typ);
end if;
when Attribute_Valid => Valid :
declare
Ptyp : constant Entity_Id := Etype (Pref);
- Btyp : Entity_Id := Base_Type (Ptyp);
+ Btyp : Entity_Id := Base_Type (Ptyp);
Tst : Node_Id;
+ Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
+ -- Save the validity checking mode. We always turn off validity
+ -- checking during process of 'Valid since this is one place
+ -- where we do not want the implicit validity checks to intefere
+ -- with the explicit validity check that the programmer is doing.
+
function Make_Range_Test return Node_Id;
-- Build the code for a range test of the form
-- Btyp!(Pref) >= Btyp!(Ptyp'First)
-- and then
-- Btyp!(Pref) <= Btyp!(Ptyp'Last)
+ ---------------------
+ -- Make_Range_Test --
+ ---------------------
+
function Make_Range_Test return Node_Id is
begin
return
Right_Opnd =>
Make_Op_Le (Loc,
Left_Opnd =>
- Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
+ Unchecked_Convert_To (Btyp,
+ Duplicate_Subexpr_No_Checks (Pref)),
Right_Opnd =>
Unchecked_Convert_To (Btyp,
-- Start of processing for Attribute_Valid
begin
+ -- Turn off validity checks. We do not want any implicit validity
+ -- checks to intefere with the explicit check from the attribute
+
+ Validity_Checks_On := False;
+
-- Floating-point case. This case is handled by the Valid attribute
-- code in the floating-point attribute run-time library.
Rtp : constant Entity_Id := Root_Type (Etype (Pref));
begin
- Expand_Fpt_Attribute (N, Rtp, New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Unchecked_Convert_To (Rtp, Pref),
- Attribute_Name => Name_Unrestricted_Access)));
+ -- If the floating-point object might be unaligned, we need
+ -- to call the special routine Unaligned_Valid, which makes
+ -- the needed copy, being careful not to load the value into
+ -- any floating-point register. The argument in this case is
+ -- obj'Address (see Unchecked_Valid routine in s-fatgen.ads).
+
+ if Is_Possibly_Unaligned_Object (Pref) then
+ Set_Attribute_Name (N, Name_Unaligned_Valid);
+ Expand_Fpt_Attribute
+ (N, Rtp, Name_Unaligned_Valid,
+ New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Pref),
+ Attribute_Name => Name_Address)));
+
+ -- In the normal case where we are sure the object is aligned,
+ -- we generate a caqll to Valid, and the argument in this case
+ -- is obj'Unrestricted_Access (after converting obj to the
+ -- right floating-point type).
+
+ else
+ Expand_Fpt_Attribute
+ (N, Rtp, Name_Valid,
+ New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Unchecked_Convert_To (Rtp, Pref),
+ Attribute_Name => Name_Unrestricted_Access)));
+ end if;
-- One more task, we still need a range check. Required
-- only if we have a constraint, since the Valid routine
Make_Function_Call (Loc,
Name =>
New_Reference_To
- (TSS (Base_Type (Ptyp), Name_uRep_To_Pos), Loc),
+ (TSS (Base_Type (Ptyp), TSS_Rep_To_Pos), Loc),
Parameter_Associations => New_List (
Pref,
New_Occurrence_Of (Standard_False, Loc))),
end if;
Analyze_And_Resolve (N, Standard_Boolean);
+ Validity_Checks_On := Save_Validity_Checks_On;
end Valid;
-----------
-- The simple case, if there is a TSS for Write, just call it
- Pname := Find_Inherited_TSS (P_Type, Name_uWrite);
+ Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
if Present (Pname) then
null;
-- this will dispatch in the class-wide case which is what we want
elsif Is_Tagged_Type (U_Type) then
- Pname := Find_Prim_Op (U_Type, Name_uWrite);
+ Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
-- All other record type cases, including protected records.
-- The latter only arise for expander generated code for
Attribute_Mechanism_Code |
Attribute_Min |
Attribute_Null_Parameter |
- Attribute_Passed_By_Reference =>
+ Attribute_Passed_By_Reference |
+ Attribute_Pool_Address =>
null;
-- The following attributes are also handled by Gigi, but return a
-- that the result is in range.
when Attribute_Aft |
- Attribute_Alignment |
Attribute_Bit |
Attribute_Max_Size_In_Storage_Elements
=>
Attribute_Machine_Overflows |
Attribute_Machine_Radix |
Attribute_Machine_Rounds |
- Attribute_Max_Interrupt_Priority |
- Attribute_Max_Priority |
Attribute_Maximum_Alignment |
Attribute_Model_Emin |
Attribute_Model_Epsilon |
Attribute_Signed_Zeros |
Attribute_Small |
Attribute_Storage_Unit |
- Attribute_Tick |
+ Attribute_Target_Name |
Attribute_Type_Class |
+ Attribute_Unconstrained_Array |
Attribute_Universal_Literal_String |
Attribute_Wchar_T_Size |
Attribute_Word_Size =>
end case;
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_N_Attribute_Reference;
----------------------
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr (First (Expressions (N))),
+ Left_Opnd =>
+ Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (Base_Type (Etype (Prefix (N))), Loc),
- Attribute_Name => Cnam))));
+ Attribute_Name => Cnam)),
+ Reason => CE_Overflow_Check_Failed));
end Expand_Pred_Succ;
function Find_Inherited_TSS
(Typ : Entity_Id;
- Nam : Name_Id) return Entity_Id
+ Nam : TSS_Name_Type) return Entity_Id
is
- P_Type : Entity_Id := Typ;
- Proc : Entity_Id;
+ Btyp : Entity_Id := Typ;
+ Proc : Entity_Id;
begin
- Proc := TSS (Base_Type (Typ), Nam);
+ loop
+ Btyp := Base_Type (Btyp);
+ Proc := TSS (Btyp, Nam);
- -- Check first if there is a TSS given for the type itself.
+ exit when Present (Proc)
+ or else not Is_Derived_Type (Btyp);
- if Present (Proc) then
- return Proc;
- end if;
+ -- If Typ is a derived type, it may inherit attributes from
+ -- some ancestor.
- -- If Typ is a derived type, it may inherit attributes from some
- -- ancestor which is not the ultimate underlying one.
+ Btyp := Etype (Btyp);
+ end loop;
- if Is_Derived_Type (P_Type) then
+ if No (Proc) then
- while Is_Derived_Type (P_Type) loop
- Proc := TSS (Base_Type (Etype (Typ)), Nam);
+ -- If nothing else, use the TSS of the root type
- if Present (Proc) then
- return Proc;
- else
- P_Type := Base_Type (Etype (P_Type));
- end if;
- end loop;
+ Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
end if;
- -- If nothing else, use the TSS of the root type.
+ return Proc;
- return TSS (Base_Type (Underlying_Type (Typ)), Nam);
end Find_Inherited_TSS;
+ ----------------------------
+ -- Find_Stream_Subprogram --
+ ----------------------------
+
+ function Find_Stream_Subprogram
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Entity_Id is
+ begin
+ if Is_Tagged_Type (Typ)
+ and then Is_Derived_Type (Typ)
+ then
+ return Find_Prim_Op (Typ, Nam);
+ else
+ return Find_Inherited_TSS (Typ, Nam);
+ end if;
+ end Find_Stream_Subprogram;
+
-----------------------
-- Get_Index_Subtype --
-----------------------
OSDN Git Service
