-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- You should have received a copy of the GNU General Public License along --
+-- with this program; see file COPYING3. If not see --
+-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
Agg : Node_Id;
Btyp : constant Entity_Id := Base_Type (Typ);
Sub : Entity_Id;
+ Sub_Ref : Node_Id;
E_T : constant Entity_Id := Equivalent_Type (Btyp);
Acc : constant Entity_Id :=
Etype (Next_Component (First_Component (E_T)));
Attribute_Name => Name_Address);
end if;
+ Sub_Ref :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Sub,
+ Attribute_Name => Name_Access);
+
+ -- We set the type of the access reference to the already generated
+ -- access_to_subprogram type, and declare the reference analyzed, to
+ -- prevent further expansion when the enclosing aggregate is analyzed.
+
+ Set_Etype (Sub_Ref, Acc);
+ Set_Analyzed (Sub_Ref);
+
Agg :=
Make_Aggregate (Loc,
- Expressions =>
- New_List (
- Obj_Ref,
- Unchecked_Convert_To (Acc,
- Make_Attribute_Reference (Loc,
- Prefix => Sub,
- Attribute_Name => Name_Address))));
+ Expressions => New_List (Obj_Ref, Sub_Ref));
Rewrite (N, Agg);
-
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
- -- needed.
+ -- For subsequent analysis, the node must retain its type. The backend
+ -- will replace it with the equivalent type where needed.
Set_Etype (N, Typ);
end Expand_Access_To_Protected_Op;
end if;
end if;
+ -- The stream operation to call maybe a renaming created by
+ -- an attribute definition clause, and may not be frozen yet.
+ -- Ensure that it has the necessary extra formals.
+
+ if not Is_Frozen (Pname) then
+ Create_Extra_Formals (Pname);
+ end if;
+
-- And now rewrite the call
Rewrite (N,
then
if Nkind (Ref_Object) /= N_Explicit_Dereference then
- -- No implicit conversion required if types match
+ -- No implicit conversion required if types match, or if
+ -- the prefix is the class_wide_type of the interface. In
+ -- either case passing an object of the interface type has
+ -- already set the pointer correctly.
- if Btyp_DDT /= Etype (Ref_Object) then
+ if Btyp_DDT = Etype (Ref_Object)
+ or else (Is_Class_Wide_Type (Etype (Ref_Object))
+ and then
+ Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object))
+ then
+ null;
+
+ else
Rewrite (Prefix (N),
Convert_To (Btyp_DDT,
New_Copy_Tree (Prefix (N))));
elsif Is_Class_Wide_Type (Ptyp)
and then Is_Interface (Ptyp)
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
and then not (Nkind (Pref) in N_Has_Entity
and then Is_Subprogram (Entity (Pref)))
then
-- A reference to P'Body_Version or P'Version is expanded to
-- Vnn : Unsigned;
- -- pragma Import (C, Vnn, "uuuuT";
+ -- pragma Import (C, Vnn, "uuuuT");
-- ...
-- Get_Version_String (Vnn)
begin
-- We have an object of a task interface class-wide type as a prefix
-- to Callable. Generate:
-
-- callable (Task_Id (Pref._disp_get_task_id));
if Ada_Version >= Ada_05
-- accessibility check on virtual machines, so we omit it.
if Ada_Version >= Ada_05
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
then
Insert_Action (N,
Make_Implicit_If_Statement (N,
elsif Is_Modular_Integer_Type (Ptyp) then
null;
- -- For other types, if range checking is enabled, we must generate
- -- a check if overflow checking is enabled.
+ -- For other types, if argument is marked as needing a range check or
+ -- overflow checking is enabled, we must generate a check.
- elsif not Overflow_Checks_Suppressed (Ptyp) then
+ elsif not Overflow_Checks_Suppressed (Ptyp)
+ or else Do_Range_Check (First (Exprs))
+ then
+ Set_Do_Range_Check (First (Exprs), False);
Expand_Pred_Succ (N);
end if;
end Pred;
-- 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.
- elsif Is_Class_Wide_Type (Ptyp) then
-
+ elsif Is_Class_Wide_Type (Ptyp)
+ or else (Id = Attribute_Size
+ and then Is_Tagged_Type (Ptyp)
+ and then Has_Unknown_Discriminants (Ptyp))
+ then
-- No need to do anything else compiling under restriction
-- No_Dispatching_Calls. During the semantic analysis we
-- already notified such violation.
Rewrite (N, New_Node);
Analyze_And_Resolve (N, Typ);
- return;
+ return;
-- Case of known RM_Size of a type
elsif Is_Modular_Integer_Type (Ptyp) then
null;
- -- For other types, if range checking is enabled, we must generate
- -- a check if overflow checking is enabled.
+ -- For other types, if argument is marked as needing a range check or
+ -- overflow checking is enabled, we must generate a check.
- elsif not Overflow_Checks_Suppressed (Ptyp) then
+ elsif not Overflow_Checks_Suppressed (Ptyp)
+ or else Do_Range_Check (First (Exprs))
+ then
+ Set_Do_Range_Check (First (Exprs), False);
Expand_Pred_Succ (N);
end if;
end Succ;
Ttyp := Underlying_Type (Ttyp);
+ -- Ada 2005: The type may be a synchronized tagged type, in which
+ -- case the tag information is stored in the corresponding record.
+
+ if Is_Concurrent_Type (Ttyp) then
+ Ttyp := Corresponding_Record_Type (Ttyp);
+ end if;
+
if Prefix_Is_Type then
-- For VMs we leave the type attribute unexpanded because
-- there's not a dispatching table to reference.
- if VM_Target = No_VM then
+ if Tagged_Type_Expansion then
Rewrite (N,
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
Analyze_And_Resolve (N, RTE (RE_Tag));
end if;
- -- (Ada 2005 (AI-251): The use of 'Tag in the sources always
+ -- Ada 2005 (AI-251): The use of 'Tag in the sources always
-- references the primary tag of the actual object. If 'Tag is
-- applied to class-wide interface objects we generate code that
-- displaces "this" to reference the base of the object.
-- Not needed for VM targets, since all handled by the VM
- if VM_Target = No_VM then
+ if Tagged_Type_Expansion then
Rewrite (N,
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
begin
-- The prefix of Terminated is of a task interface class-wide type.
-- Generate:
-
-- terminated (Task_Id (Pref._disp_get_task_id));
if Ada_Version >= Ada_05
end if;
Analyze_And_Resolve (N, Typ);
+
+ -- If the argument is marked as requiring a range check then generate
+ -- it here.
+
+ elsif Do_Range_Check (First (Exprs)) then
+ Set_Do_Range_Check (First (Exprs), False);
+ Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
end if;
end Val;
---------------------
function Make_Range_Test return Node_Id is
+ Temp : constant Node_Id := Duplicate_Subexpr (Pref);
+
begin
+ -- The value whose validity is being checked has been captured in
+ -- an object declaration. We certainly don't want this object to
+ -- appear valid because the declaration initializes it!
+
+ if Is_Entity_Name (Temp) then
+ Set_Is_Known_Valid (Entity (Temp), False);
+ end if;
+
return
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ge (Loc,
Left_Opnd =>
- Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
+ Unchecked_Convert_To (Btyp, Temp),
Right_Opnd =>
Unchecked_Convert_To (Btyp,
Right_Opnd =>
Make_Op_Le (Loc,
Left_Opnd =>
- Unchecked_Convert_To (Btyp,
- Duplicate_Subexpr_No_Checks (Pref)),
+ Unchecked_Convert_To (Btyp, Temp),
Right_Opnd =>
Unchecked_Convert_To (Btyp,
Attribute_Address_Size |
Attribute_Base |
Attribute_Class |
+ Attribute_Compiler_Version |
Attribute_Default_Bit_Order |
Attribute_Delta |
Attribute_Denorm |
OSDN Git Service
