+2009-05-06 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch5.adb, exp_util.adb, exp_attr.adb, sem_util.adb, sem_res.adb,
+ targparm.adb, targparm.ads, exp_ch4.adb, exp_ch6.adb, exp_disp.adb,
+ opt.ads, exp_aggr.adb, exp_intr.adb, sem_disp.adb, exp_ch3.adb
+ (Tagged_Type_Expansion): New flag.
+ Replace use of VM_Target related to tagged types expansion by
+ Tagged_Type_Expansion, since tagged type expansion is not necessarily
+ linked to VM targets.
+
2009-05-06 Robert Dewar <dewar@adacore.com>
+ * sem_attr.adb: Add processing for Standard'Compiler_Version
+
* sinput.adb (Expr_Last_Char): Fix some copy-paste errors for paren
skipping.
(Expr_First_Char): Add ??? comment that paren skipping needs work
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-- with tagged components, but not clear whether it's worthwhile ???;
-- in the case of the JVM, object tags are handled implicitly)
- if Is_Tagged_Type (Component_Type (Typ)) and then VM_Target = No_VM then
+ if Is_Tagged_Type (Component_Type (Typ))
+ and then Tagged_Type_Expansion
+ then
return False;
end if;
Append_To (L, A);
-- Adjust the tag if tagged (because of possible view
- -- conversions), unless compiling for the Java VM where
+ -- conversions), unless compiling for a VM where
-- tags are implicit.
if Present (Comp_Type)
and then Is_Tagged_Type (Comp_Type)
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
then
A :=
Make_OK_Assignment_Statement (Loc,
-- the subsequent deep_adjust works properly (unless VM_Target,
-- where tags are implicit).
- if VM_Target = No_VM then
+ if Tagged_Type_Expansion then
Instr :=
Make_OK_Assignment_Statement (Loc,
Name =>
-- tmp.comp._tag := comp_typ'tag;
- if Is_Tagged_Type (Comp_Type) and then VM_Target = No_VM then
+ if Is_Tagged_Type (Comp_Type)
+ and then Tagged_Type_Expansion
+ then
Instr :=
Make_OK_Assignment_Statement (Loc,
Name =>
elsif Is_CPP_Class (Typ) then
null;
- elsif Is_Tagged_Type (Typ) and then VM_Target = No_VM then
+ elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
Instr :=
Make_OK_Assignment_Statement (Loc,
Name =>
else
Set_Etype (N, Typ);
- if VM_Target = No_VM then
+ if Tagged_Type_Expansion then
Expand_Record_Aggregate (N,
Orig_Tag =>
New_Occurrence_Of
or else (Is_Entity_Name (Expr_Q)
and then
Ekind (Entity (Expr_Q)) in Formal_Kind))
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
then
Static_Components := False;
return True;
if Present (Orig_Tag) then
Tag_Value := Orig_Tag;
- elsif VM_Target /= No_VM then
+ elsif not Tagged_Type_Expansion then
Tag_Value := Empty;
else
Tag_Value :=
-- For a root type, the tag component is added (unless compiling
-- for the VMs, where tags are implicit).
- elsif VM_Target = No_VM then
+ elsif Tagged_Type_Expansion then
declare
Tag_Name : constant Node_Id :=
New_Occurrence_Of
begin
return Static_Dispatch_Tables
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
and then RTU_Loaded (Ada_Tags)
-- Avoid circularity when rebuilding the compiler
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
-- 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,
-- 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
-- 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),
-- Suppress the tag adjustment when VM_Target because VM tags are
-- represented implicitly in objects.
- if Is_Tagged_Type (Typ) and then VM_Target = No_VM then
+ if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
Append_To (Res,
Make_Assignment_Statement (Loc,
Name =>
if not Is_Tagged_Type (Rec_Type)
or else Etype (Rec_Type) = Rec_Type
or else not Has_Discriminants (Etype (Rec_Type))
- or else VM_Target /= No_VM
+ or else not Tagged_Type_Expansion
then
return;
end if;
if Is_Tagged_Type (Rec_Type)
and then not Is_CPP_Class (Rec_Type)
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
and then not No_Run_Time_Mode
then
-- Initialize the primary tag
-- Force construction of dispatch tables of library level tagged types
- if VM_Target = No_VM
+ if Tagged_Type_Expansion
and then Static_Dispatch_Tables
and then Is_Library_Level_Entity (Def_Id)
and then Is_Library_Level_Tagged_Type (Base_Typ)
or else
not Is_Ancestor (Root_Type (Typ), Etype (Expr)))
and then Comes_From_Source (Def_Id)
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
then
declare
Decl_1 : Node_Id;
if Is_Tagged_Type (Typ)
and then not Is_Class_Wide_Type (Typ)
and then not Is_CPP_Class (Typ)
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
and then Nkind (Expr) /= N_Aggregate
then
-- The re-assignment of the tag has to be done even if the
if Has_Task (Typ)
and then not Restriction_Active (No_Implicit_Heap_Allocations)
and then not Global_Discard_Names
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
then
Set_Uses_Sec_Stack (Proc_Id);
end if;
-- Create the tag entities with a minimum decoration
- if VM_Target = No_VM then
+ if Tagged_Type_Expansion then
Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id));
end if;
-- VM_Target because the dispatching mechanism is handled
-- internally by the VMs.
- if VM_Target = No_VM then
+ if Tagged_Type_Expansion then
Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id));
-- Generate dispatch table of locally defined tagged type.
-- Dispatch tables of library level tagged types are built
-- later (see Analyze_Declarations).
- if VM_Target = No_VM
- and then not Has_Static_DT
- then
+ if not Has_Static_DT then
Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
end if;
end if;
Adjust_Discriminants (Def_Id);
- if VM_Target = No_VM or else not Is_Interface (Def_Id) then
+ if Tagged_Type_Expansion or else not Is_Interface (Def_Id) then
-- Do not need init for interfaces on e.g. CIL since they're
-- abstract. Helps operation of peverify (the PE Verify tool).
-- these bodies if No_Dispatching_Calls, Ravenscar or ZFP is active.
if Ada_Version >= Ada_05
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
and then not Restriction_Active (No_Dispatching_Calls)
and then not Restriction_Active (No_Select_Statements)
and then RTE_Available (RE_Select_Specific_Data)
-- these bodies if No_Dispatching_Calls, Ravenscar or ZFP is active.
if Ada_Version >= Ada_05
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
and then not Is_Interface (Tag_Typ)
and then
((Is_Interface (Etype (Tag_Typ))
-- Do nothing in case of VM targets: the virtual machine will handle
-- interfaces directly.
- if VM_Target /= No_VM then
+ if not Tagged_Type_Expansion then
return;
end if;
-- there does not seem to be any practical way of implementing it.
if Ada_Version >= Ada_05
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
and then Is_Class_Wide_Type (DesigT)
and then not Scope_Suppress (Accessibility_Check)
and then
if Is_Class_Wide_Type (Etype (Exp))
and then Is_Interface (Etype (Exp))
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
then
Set_Expression
(Expression (N),
-- Suppress the tag assignment when VM_Target because VM tags are
-- represented implicitly in objects.
- if VM_Target /= No_VM then
+ if not Tagged_Type_Expansion then
null;
-- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
-- are not explicitly represented in Java objects, so the
-- normal tagged membership expansion is not what we want).
- if VM_Target = No_VM then
+ if Tagged_Type_Expansion then
Rewrite (N, Tagged_Membership (N));
Analyze_And_Resolve (N, Rtyp);
end if;
-- on such run-time unit.
and then
- (VM_Target /= No_VM
+ (not Tagged_Type_Expansion
or else not
(RTU_Loaded (Ada_Tags)
and then Nkind (Prefix (N)) = N_Selected_Component
-- --
-- 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- --
-- does not seem to be any practical way to implement this check.
elsif Ada_Version >= Ada_05
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
and then Is_Class_Wide_Type (R_Type)
and then not Scope_Suppress (Accessibility_Check)
and then
Save_Tag : constant Boolean := Is_Tagged_Type (T)
and then not No_Ctrl_Actions (N)
- and then VM_Target = No_VM;
+ and then Tagged_Type_Expansion;
-- Tags are not saved and restored when VM_Target because VM tags are
-- represented implicitly in objects.
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Validsw; use Validsw;
if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
and then Present (Controlling_Argument (N))
then
- if VM_Target = No_VM then
+ if Tagged_Type_Expansion then
Expand_Dispatching_Call (N);
-- The following return is worrisome. Is it really OK to
and then not Is_Abstract_Subprogram (Subp)
and then Present (DTC_Entity (Subp))
and then Present (Scope (DTC_Entity (Subp)))
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
and then not Restriction_Active (No_Dispatching_Calls)
and then RTE_Available (RE_Tag)
then
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
begin
if not Expander_Active
- or else VM_Target /= No_VM
+ or else not Tagged_Type_Expansion
then
return;
end if;
or else (not Is_Class_Wide_Type (Iface_Typ)
and then Is_Interface (Iface_Typ)));
- if VM_Target /= No_VM then
+ if not Tagged_Type_Expansion then
-- For VM, just do a conversion ???
-- --
-- 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- --
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
+with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Urealp; use Urealp;
-- checks are suppressed for the result type or VM_Target /= No_VM
if Tag_Checks_Suppressed (Etype (Result_Typ))
- or else VM_Target /= No_VM
+ or else not Tagged_Type_Expansion
then
null;
-- free (Base_Address (Obj_Ptr))
if Is_Interface (Directly_Designated_Type (Typ))
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
then
Set_Expression (Free_Node,
Unchecked_Convert_To (Typ,
-- --
-- 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- --
-- initialization itself (and doesn't need or want the
-- additional intermediate type to handle the assignment).
- if Expander_Active and then VM_Target = No_VM then
+ if Expander_Active and then Tagged_Type_Expansion then
EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
end if;
-- multiplied by the factor given here. The default value is used if no
-- -gnatT switch appears.
+ Tagged_Type_Expansion : Boolean := True;
+ -- GNAT
+ -- Set True if tagged types and interfaces should be expanded by the
+ -- front-end. If False, the original tree is left unexpanded for
+ -- tagged types and dispatching calls, assuming the underlying target
+ -- supports it (e.g. case of JVM).
+
Task_Dispatching_Policy : Character := ' ';
-- GNAT, GNATBIND
-- Set to ' ' for the default case (no task dispatching policy specified).
when Attribute_Compiler_Version =>
Check_E0;
Check_Standard_Prefix;
- Rewrite (N, Make_String_Literal (Loc, Gnat_Static_Version_String));
+ Rewrite (N, Make_String_Literal (Loc, "GNAT " & Gnat_Version_String));
Analyze_And_Resolve (N, Standard_String);
--------------------
with Snames; use Snames;
with Stand; use Stand;
with Sinfo; use Sinfo;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-- the VM back-ends directly handle the generation of dispatching
-- calls and would have to undo any expansion to an indirect call.
- if VM_Target = No_VM then
+ if Tagged_Type_Expansion then
Expand_Dispatching_Call (Call_Node);
-- Expansion of a dispatching call results in an indirect call, which in
with Stand; use Stand;
with Stringt; use Stringt;
with Style; use Style;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Urealp; use Urealp;
-- undesired dependence on such run-time unit.
and then
- (VM_Target /= No_VM
- or else not
- (RTU_Loaded (Ada_Tags)
- and then Nkind (Prefix (N)) = N_Selected_Component
- and then Present (Entity (Selector_Name (Prefix (N))))
- and then Entity (Selector_Name (Prefix (N))) =
- RTE_Record_Component (RE_Prims_Ptr)))
+ (not Tagged_Type_Expansion
+ or else not
+ (RTU_Loaded (Ada_Tags)
+ and then Nkind (Prefix (N)) = N_Selected_Component
+ and then Present (Entity (Selector_Name (Prefix (N))))
+ and then Entity (Selector_Name (Prefix (N))) =
+ RTE_Record_Component (RE_Prims_Ptr)))
then
Apply_Range_Check (Drange, Etype (Index));
end if;
-- uninitialized case. Note that this applies both to the
-- uTag entry and the main vtable pointer (CPP_Class case).
- and then (VM_Target = No_VM or else not Is_Tag (Ent))
+ and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
then
return False;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-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- --
when CLI =>
if Result then
VM_Target := CLI_Target;
+ Tagged_Type_Expansion := False;
end if;
when CRT => Configurable_Run_Time_On_Target := Result;
when JVM =>
if Result then
VM_Target := JVM_Target;
+ Tagged_Type_Expansion := False;
end if;
when MOV => Machine_Overflows_On_Target := Result;
type Virtual_Machine_Kind is (No_VM, JVM_Target, CLI_Target);
VM_Target : Virtual_Machine_Kind := No_VM;
-- Kind of virtual machine targetted
- -- Needs comments, don't depend on names ???
+ -- No_VM: no virtual machine, default case of a standard processor
+ -- JVM_Target: Java Virtual Machine
+ -- CLI_Target: CLI/.NET Virtual Machine
-------------------------------
-- Backend Arithmetic Checks --
OSDN Git Service
