-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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 Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
-with Errout; use Errout;
+with Expander; use Expander;
with Exp_Atag; use Exp_Atag;
with Exp_Ch4; use Exp_Ch4;
with Exp_Ch7; use Exp_Ch7;
with Exp_Fixd; use Exp_Fixd;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
-with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id);
-- Rewrite the node by the appropriate string or positive constant.
-- Nam can be one of the following:
- -- Name_File - expand string that is the name of source file
- -- Name_Line - expand integer line number
- -- Name_Source_Location - expand string of form file:line
- -- Name_Enclosing_Entity - expand string with name of enclosing entity
+ -- Name_File - expand string name of source file
+ -- Name_Line - expand integer line number
+ -- Name_Source_Location - expand string of form file:line
+ -- Name_Enclosing_Entity - expand string name of enclosing entity
+ -- Name_Compilation_Date - expand string with compilation date
+ -- Name_Compilation_Time - expand string with compilation time
+
+ procedure Write_Entity_Name (E : Entity_Id);
+ -- Recursive procedure to construct string for qualified name of enclosing
+ -- program unit. The qualification stops at an enclosing scope has no
+ -- source name (block or loop). If entity is a subprogram instance, skip
+ -- enclosing wrapper package. The name is appended to the current contents
+ -- of Name_Buffer, incrementing Name_Len.
+
+ ---------------------
+ -- Add_Source_Info --
+ ---------------------
+
+ procedure Add_Source_Info (Loc : Source_Ptr; Nam : Name_Id) is
+ Ent : Entity_Id;
+
+ Save_NB : constant String := Name_Buffer (1 .. Name_Len);
+ Save_NL : constant Natural := Name_Len;
+ -- Save current Name_Buffer contents
+
+ begin
+ Name_Len := 0;
+
+ -- Line
+
+ case Nam is
+
+ when Name_Line =>
+ Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (Loc)));
+
+ when Name_File =>
+ Get_Decoded_Name_String
+ (Reference_Name (Get_Source_File_Index (Loc)));
+
+ when Name_Source_Location =>
+ Build_Location_String (Loc);
+
+ when Name_Enclosing_Entity =>
+
+ -- Skip enclosing blocks to reach enclosing unit
+
+ Ent := Current_Scope;
+ while Present (Ent) loop
+ exit when Ekind (Ent) /= E_Block
+ and then Ekind (Ent) /= E_Loop;
+ Ent := Scope (Ent);
+ end loop;
+
+ -- Ent now points to the relevant defining entity
+
+ Write_Entity_Name (Ent);
+
+ when Name_Compilation_Date =>
+ declare
+ subtype S13 is String (1 .. 3);
+ Months : constant array (1 .. 12) of S13 :=
+ ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
+
+ M1 : constant Character := Opt.Compilation_Time (6);
+ M2 : constant Character := Opt.Compilation_Time (7);
+
+ MM : constant Natural range 1 .. 12 :=
+ (Character'Pos (M1) - Character'Pos ('0')) * 10 +
+ (Character'Pos (M2) - Character'Pos ('0'));
+
+ begin
+ -- Reformat ISO date into MMM DD YYYY (__DATE__) format
+
+ Name_Buffer (1 .. 3) := Months (MM);
+ Name_Buffer (4) := ' ';
+ Name_Buffer (5 .. 6) := Opt.Compilation_Time (9 .. 10);
+ Name_Buffer (7) := ' ';
+ Name_Buffer (8 .. 11) := Opt.Compilation_Time (1 .. 4);
+ Name_Len := 11;
+ end;
+
+ when Name_Compilation_Time =>
+ Name_Buffer (1 .. 8) := Opt.Compilation_Time (12 .. 19);
+ Name_Len := 8;
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- Prepend original Name_Buffer contents
+
+ Name_Buffer (Save_NL + 1 .. Save_NL + Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
+ Name_Buffer (1 .. Save_NL) := Save_NB;
+ end Add_Source_Info;
---------------------------------
-- Expand_Binary_Operator_Call --
Result_Typ : Entity_Id;
begin
+ -- Remove side effects from tag argument early, before rewriting
+ -- the dispatching constructor call, as Remove_Side_Effects relies
+ -- on Tag_Arg's Parent link properly attached to the tree (once the
+ -- call is rewritten, the Parent is inconsistent as it points to the
+ -- rewritten node, which is not the syntactic parent of the Tag_Arg
+ -- anymore).
+
+ Remove_Side_Effects (Tag_Arg);
+
-- The subprogram is the third actual in the instantiation, and is
-- retrieved from the corresponding renaming declaration. However,
-- freeze nodes may appear before, so we retrieve the declaration
Act_Constr := Entity (Name (Act_Rename));
Result_Typ := Class_Wide_Type (Etype (Act_Constr));
- -- Ada 2005 (AI-251): If the result is an interface type, the function
- -- returns a class-wide interface type (otherwise the resulting object
- -- would be abstract!)
-
if Is_Interface (Etype (Act_Constr)) then
- Set_Etype (Act_Constr, Result_Typ);
- -- If the result type is not parent of Tag_Arg then we need to
- -- locate the tag of the secondary dispatch table.
+ -- If the result type is not known to be a parent of Tag_Arg then we
+ -- need to locate the tag of the secondary dispatch table.
if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg),
Use_Full_View => True)
declare
Fname : constant Node_Id :=
- New_Reference_To (RTE (RE_Secondary_Tag), Loc);
+ New_Occurrence_Of (RTE (RE_Secondary_Tag), Loc);
begin
pragma Assert (not Is_Interface (Etype (Tag_Arg)));
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'V'),
Object_Definition =>
- New_Reference_To (RTE (RE_Tag), Loc),
+ New_Occurrence_Of (RTE (RE_Tag), Loc),
Expression =>
Make_Function_Call (Loc,
- Name => Fname,
+ Name => Fname,
Parameter_Associations => New_List (
Relocate_Node (Tag_Arg),
- New_Reference_To
+ New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table
(Etype (Etype (Act_Constr))))),
Loc))));
Set_Controlling_Argument (Cnstr_Call,
New_Occurrence_Of (Defining_Identifier (Iface_Tag), Loc));
else
- Remove_Side_Effects (Tag_Arg);
Set_Controlling_Argument (Cnstr_Call,
Relocate_Node (Tag_Arg));
end if;
elsif not Is_Interface (Result_Typ) then
declare
- Obj_Tag_Node : Node_Id := Duplicate_Subexpr (Tag_Arg);
+ Obj_Tag_Node : Node_Id := New_Copy_Tree (Tag_Arg);
CW_Test_Node : Node_Id;
begin
Build_CW_Membership (Loc,
Obj_Tag_Node => Obj_Tag_Node,
Typ_Tag_Node =>
- New_Reference_To (
+ New_Occurrence_Of (
Node (First_Elmt (Access_Disp_Table (
Root_Type (Result_Typ)))), Loc),
Related_Nod => N,
Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Tag_Arg),
+ Prefix => New_Copy_Tree (Tag_Arg),
Attribute_Name => Name_Address),
- New_Reference_To (
+ New_Occurrence_Of (
Node (First_Elmt (Access_Disp_Table (
Root_Type (Result_Typ)))), Loc)))),
Then_Statements =>
New_Occurrence_Of (Choice_Parameter (P), Loc))));
exit;
- -- Keep climbing!
+ -- Keep climbing
else
P := Parent (P);
New_Occurrence_Of (Standard_Character, Loc)),
Make_Pragma (Loc,
- Chars => Name_Import,
+ Chars => Name_Import,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Make_Identifier (Loc, Name_Ada)),
elsif Nam = Name_Generic_Dispatching_Constructor then
Expand_Dispatching_Constructor_Call (N);
- elsif Nam = Name_Import_Address
- or else
- Nam = Name_Import_Largest_Value
- or else
- Nam = Name_Import_Value
+ elsif Nam_In (Nam, Name_Import_Address,
+ Name_Import_Largest_Value,
+ Name_Import_Value)
then
Expand_Import_Call (N);
elsif Nam = Name_To_Pointer then
Expand_To_Pointer (N);
- elsif Nam = Name_File
- or else Nam = Name_Line
- or else Nam = Name_Source_Location
- or else Nam = Name_Enclosing_Entity
+ elsif Nam_In (Nam, Name_File,
+ Name_Line,
+ Name_Source_Location,
+ Name_Enclosing_Entity,
+ Name_Compilation_Date,
+ Name_Compilation_Time)
then
Expand_Source_Info (N, Nam);
-- conventions and this has already been checked.
elsif Present (Alias (E)) then
- Expand_Intrinsic_Call (N, Alias (E));
+ Expand_Intrinsic_Call (N, Alias (E));
elsif Nkind (N) in N_Binary_Op then
Expand_Binary_Operator_Call (N);
- -- The only other case is where an external name was specified,
- -- since this is the only way that an otherwise unrecognized
- -- name could escape the checking in Sem_Prag. Nothing needs
- -- to be done in such a case, since we pass such a call to the
- -- back end unchanged.
+ -- The only other case is where an external name was specified, since
+ -- this is the only way that an otherwise unrecognized name could
+ -- escape the checking in Sem_Prag. Nothing needs to be done in such
+ -- a case, since we pass such a call to the back end unchanged.
else
null;
-- end if;
Rewrite (N,
- Make_Conditional_Expression (Loc,
+ Make_If_Expression (Loc,
Expressions => New_List (
Make_Op_Lt (Loc,
Left_Opnd => Duplicate_Subexpr (Opnd),
New_Occurrence_Of (Standard_True, Loc),
- Make_Conditional_Expression (Loc,
+ Make_If_Expression (Loc,
Expressions => New_List (
Make_Op_Gt (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Opnd),
-- As a result, whenever a shift is used in the source program, it will
-- remain as a call until converted by this routine to the operator node
- -- form which Gigi is expecting to see.
+ -- form which the back end is expecting to see.
-- Note: it is possible for the expander to generate shift operator nodes
-- directly, which will be analyzed in the normal manner by calling Analyze
-- and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is
- Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
+ Entyp : constant Entity_Id := Etype (E);
Left : constant Node_Id := First_Actual (N);
+ Loc : constant Source_Ptr := Sloc (N);
Right : constant Node_Id := Next_Actual (Left);
Ltyp : constant Node_Id := Etype (Left);
Rtyp : constant Node_Id := Etype (Right);
+ Typ : constant Entity_Id := Etype (N);
Snode : Node_Id;
begin
Snode := New_Node (K, Loc);
- Set_Left_Opnd (Snode, Relocate_Node (Left));
Set_Right_Opnd (Snode, Relocate_Node (Right));
Set_Chars (Snode, Chars (E));
- Set_Etype (Snode, Base_Type (Typ));
+ Set_Etype (Snode, Base_Type (Entyp));
Set_Entity (Snode, E);
if Compile_Time_Known_Value (Type_High_Bound (Rtyp))
Set_Shift_Count_OK (Snode, True);
end if;
- -- Do the rewrite. Note that we don't call Analyze and Resolve on
- -- this node, because it already got analyzed and resolved when
- -- it was a function call!
+ if Typ = Entyp then
- Rewrite (N, Snode);
- Set_Analyzed (N);
- end Expand_Shift;
-
- ------------------------
- -- Expand_Source_Info --
- ------------------------
-
- procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Ent : Entity_Id;
+ -- Note that we don't call Analyze and Resolve on this node, because
+ -- it already got analyzed and resolved when it was a function call.
- procedure Write_Entity_Name (E : Entity_Id);
- -- Recursive procedure to construct string for qualified name of
- -- enclosing program unit. The qualification stops at an enclosing
- -- scope has no source name (block or loop). If entity is a subprogram
- -- instance, skip enclosing wrapper package.
+ Set_Left_Opnd (Snode, Relocate_Node (Left));
+ Rewrite (N, Snode);
+ Set_Analyzed (N);
- -----------------------
- -- Write_Entity_Name --
- -----------------------
-
- procedure Write_Entity_Name (E : Entity_Id) is
- SDef : Source_Ptr;
- TDef : constant Source_Buffer_Ptr :=
- Source_Text (Get_Source_File_Index (Sloc (E)));
-
- begin
- -- Nothing to do if at outer level
-
- if Scope (E) = Standard_Standard then
- null;
-
- -- If scope comes from source, write its name
-
- elsif Comes_From_Source (Scope (E)) then
- Write_Entity_Name (Scope (E));
- Add_Char_To_Name_Buffer ('.');
-
- -- If in wrapper package skip past it
+ -- However, we do call the expander, so that the expansion for
+ -- rotates and shift_right_arithmetic happens if Modify_Tree_For_C
+ -- is set.
- elsif Is_Wrapper_Package (Scope (E)) then
- Write_Entity_Name (Scope (Scope (E)));
- Add_Char_To_Name_Buffer ('.');
+ if Expander_Active then
+ Expand (N);
+ end if;
- -- Otherwise nothing to output (happens in unnamed block statements)
+ else
+ -- If the context type is not the type of the operator, it is an
+ -- inherited operator for a derived type. Wrap the node in a
+ -- conversion so that it is type-consistent for possible further
+ -- expansion (e.g. within a lock-free protected type).
- else
- null;
- end if;
+ Set_Left_Opnd (Snode,
+ Unchecked_Convert_To (Base_Type (Entyp), Relocate_Node (Left)));
+ Rewrite (N, Unchecked_Convert_To (Typ, Snode));
- -- Loop to output the name
+ -- Analyze and resolve result formed by conversion to target type
- -- is this right wrt wide char encodings ??? (no!)
+ Analyze_And_Resolve (N, Typ);
+ end if;
+ end Expand_Shift;
- SDef := Sloc (E);
- while TDef (SDef) in '0' .. '9'
- or else TDef (SDef) >= 'A'
- or else TDef (SDef) = ASCII.ESC
- loop
- Add_Char_To_Name_Buffer (TDef (SDef));
- SDef := SDef + 1;
- end loop;
- end Write_Entity_Name;
+ ------------------------
+ -- Expand_Source_Info --
+ ------------------------
- -- Start of processing for Expand_Source_Info
+ procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Ent : Entity_Id;
begin
-- Integer cases
Write_Entity_Name (Ent);
+ when Name_Compilation_Date =>
+ declare
+ subtype S13 is String (1 .. 3);
+ Months : constant array (1 .. 12) of S13 :=
+ ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
+
+ M1 : constant Character := Opt.Compilation_Time (6);
+ M2 : constant Character := Opt.Compilation_Time (7);
+
+ MM : constant Natural range 1 .. 12 :=
+ (Character'Pos (M1) - Character'Pos ('0')) * 10 +
+ (Character'Pos (M2) - Character'Pos ('0'));
+
+ begin
+ -- Reformat ISO date into MMM DD YYYY (__DATE__) format
+
+ Name_Buffer (1 .. 3) := Months (MM);
+ Name_Buffer (4) := ' ';
+ Name_Buffer (5 .. 6) := Opt.Compilation_Time (9 .. 10);
+ Name_Buffer (7) := ' ';
+ Name_Buffer (8 .. 11) := Opt.Compilation_Time (1 .. 4);
+ Name_Len := 11;
+ end;
+
+ when Name_Compilation_Time =>
+ Name_Buffer (1 .. 8) := Opt.Compilation_Time (12 .. 19);
+ Name_Len := 8;
+
when others =>
raise Program_Error;
end case;
Finalizer_Data : Finalization_Exception_Data;
Blk : Node_Id := Empty;
+ Blk_Id : Entity_Id;
Deref : Node_Id;
Final_Code : List_Id;
Free_Arg : Node_Id;
-- that we analyze some generated statements before properly attaching
-- them to the tree, and that can disturb current value settings.
+ Dummy : Entity_Id;
+ -- This variable captures an unused dummy internal entity, see the
+ -- comment associated with its use.
+
begin
-- Nothing to do if we know the argument is null
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Final_Call (
- Obj_Ref => Deref,
- Typ => Desig_T)),
+ Statements => New_List (
+ Make_Final_Call (Obj_Ref => Deref, Typ => Desig_T)),
Exception_Handlers => New_List (
Build_Exception_Handler (Finalizer_Data)))));
-- For .NET/JVM, detach the object from the containing finalization
-- collection before finalizing it.
- if VM_Target /= No_VM
- and then Is_Controlled (Desig_T)
- then
+ if VM_Target /= No_VM and then Is_Controlled (Desig_T) then
Prepend_To (Final_Code,
Make_Detach_Call (New_Copy_Tree (Arg)));
end if;
-- protected by an abort defer/undefer pair.
if Abort_Allowed then
- Prepend_To (Final_Code,
- Build_Runtime_Call (Loc, RE_Abort_Defer));
+ Prepend_To (Final_Code, Build_Runtime_Call (Loc, RE_Abort_Defer));
Blk :=
Make_Block_Statement (Loc, Handled_Statement_Sequence =>
Statements => Final_Code,
At_End_Proc =>
New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)));
+ Add_Block_Identifier (Blk, Blk_Id);
Append (Blk, Stmts);
+
else
+ -- Generate a dummy entity to ensure that the internal symbols are
+ -- in sync when a unit is compiled with and without aborts.
+
+ Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
Append_List_To (Stmts, Final_Code);
end if;
end if;
-- For a task type, call Free_Task before freeing the ATCB
if Is_Task_Type (Desig_T) then
- declare
- Stat : Node_Id := Prev (N);
- Nam1 : Node_Id;
- Nam2 : Node_Id;
- begin
- -- An Abort followed by a Free will not do what the user
- -- expects, because the abort is not immediate. This is
- -- worth a friendly warning.
-
- while Present (Stat)
- and then not Comes_From_Source (Original_Node (Stat))
- loop
- Prev (Stat);
- end loop;
-
- if Present (Stat)
- and then Nkind (Original_Node (Stat)) = N_Abort_Statement
- then
- Stat := Original_Node (Stat);
- Nam1 := First (Names (Stat));
- Nam2 := Original_Node (First (Parameter_Associations (N)));
-
- if Nkind (Nam1) = N_Explicit_Dereference
- and then Is_Entity_Name (Prefix (Nam1))
- and then Is_Entity_Name (Nam2)
- and then Entity (Prefix (Nam1)) = Entity (Nam2)
- then
- Error_Msg_N ("abort may take time to complete?", N);
- Error_Msg_N ("\deallocation might have no effect?", N);
- Error_Msg_N ("\safer to wait for termination.?", N);
- end if;
- end if;
- end;
+ -- We used to detect the case of Abort followed by a Free here,
+ -- because the Free wouldn't actually free if it happens before
+ -- the aborted task actually terminates. The warning was removed,
+ -- because Free now works properly (the task will be freed once
+ -- it terminates).
Append_To
(Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg)));
end if;
end if;
- -- Normal processing for non-controlled types
+ -- Normal processing for non-controlled types. The argument to free is
+ -- a renaming rather than a constant to ensure that the original context
+ -- is always set to null after the deallocation takes place.
- Free_Arg := Duplicate_Subexpr_No_Checks (Arg);
+ Free_Arg := Duplicate_Subexpr_No_Checks (Arg, Renaming_Req => True);
Free_Node := Make_Free_Statement (Loc, Empty);
Append_To (Stmts, Free_Node);
Set_Storage_Pool (Free_Node, Pool);
if Is_RTE (Pool, RE_SS_Pool) then
null;
+ -- If the pool object is of a simple storage pool type, then attempt
+ -- to locate the type's Deallocate procedure, if any, and set the
+ -- free operation's procedure to call. If the type doesn't have a
+ -- Deallocate (which is allowed), then the actual will simply be set
+ -- to null.
+
+ elsif Present (Get_Rep_Pragma
+ (Etype (Pool), Name_Simple_Storage_Pool_Type))
+ then
+ declare
+ Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
+ Dealloc_Op : Entity_Id;
+ begin
+ Dealloc_Op := Get_Name_Entity_Id (Name_Deallocate);
+ while Present (Dealloc_Op) loop
+ if Scope (Dealloc_Op) = Scope (Pool_Type)
+ and then Present (First_Formal (Dealloc_Op))
+ and then Etype (First_Formal (Dealloc_Op)) = Pool_Type
+ then
+ Set_Procedure_To_Call (Free_Node, Dealloc_Op);
+ exit;
+ else
+ Dealloc_Op := Homonym (Dealloc_Op);
+ end if;
+ end loop;
+ end;
+
-- Case of a class-wide pool type: make a dispatching call to
-- Deallocate through the class-wide Deallocate_Any.
if Present (Procedure_To_Call (Free_Node)) then
- -- For all cases of a Deallocate call, the back-end needs to be
- -- able to compute the size of the object being freed. This may
- -- require some adjustments for objects of dynamic size.
+ -- For all cases of a Deallocate call, the back-end needs to be able
+ -- to compute the size of the object being freed. This may require
+ -- some adjustments for objects of dynamic size.
--
-- If the type is class wide, we generate an implicit type with the
-- right dynamic size, so that the deallocate call gets the right
if Is_Class_Wide_Type (Desig_T)
or else
(Is_Array_Type (Desig_T)
- and then not Is_Constrained (Desig_T)
- and then Is_Packed (Desig_T))
+ and then not Is_Constrained (Desig_T)
+ and then Is_Packed (Desig_T))
then
declare
Deref : constant Node_Id :=
D_Type : Entity_Id;
begin
+ -- Perform minor decoration as it is needed by the side effect
+ -- removal mechanism.
+
+ Set_Etype (Deref, Desig_T);
Set_Parent (Deref, Free_Node);
D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T);
Set_Expression (Free_Node,
Unchecked_Convert_To (Typ,
Make_Function_Call (Loc,
- Name => New_Reference_To (RTE (RE_Base_Address), Loc),
+ Name => New_Occurrence_Of (RTE (RE_Base_Address), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Free_Arg)))));
Set_Expression (Free_Node, Free_Arg);
end if;
- -- Only remaining step is to set result to null, or generate a
- -- raise of constraint error if the target object is "not null".
+ -- Only remaining step is to set result to null, or generate a raise of
+ -- Constraint_Error if the target object is "not null".
if Can_Never_Be_Null (Etype (Arg)) then
Append_To (Stmts,
Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg));
Rewrite (N,
- Make_Conditional_Expression (Loc,
+ Make_If_Expression (Loc,
Expressions => New_List (
Make_Op_Eq (Loc,
Left_Opnd => New_Copy_Tree (Arg),
Analyze (N);
end Expand_To_Pointer;
+ -----------------------
+ -- Write_Entity_Name --
+ -----------------------
+
+ procedure Write_Entity_Name (E : Entity_Id) is
+ SDef : Source_Ptr;
+ TDef : constant Source_Buffer_Ptr :=
+ Source_Text (Get_Source_File_Index (Sloc (E)));
+
+ begin
+ -- Nothing to do if at outer level
+
+ if Scope (E) = Standard_Standard then
+ null;
+
+ -- If scope comes from source, write its name
+
+ elsif Comes_From_Source (Scope (E)) then
+ Write_Entity_Name (Scope (E));
+ Add_Char_To_Name_Buffer ('.');
+
+ -- If in wrapper package skip past it
+
+ elsif Is_Wrapper_Package (Scope (E)) then
+ Write_Entity_Name (Scope (Scope (E)));
+ Add_Char_To_Name_Buffer ('.');
+
+ -- Otherwise nothing to output (happens in unnamed block statements)
+
+ else
+ null;
+ end if;
+
+ -- Output the name
+
+ SDef := Sloc (E);
+
+ -- Check for operator name in quotes
+
+ if TDef (SDef) = '"' then
+ Add_Char_To_Name_Buffer ('"');
+
+ -- Loop to output characters of operator name and terminating quote
+
+ loop
+ SDef := SDef + 1;
+ Add_Char_To_Name_Buffer (TDef (SDef));
+ exit when TDef (SDef) = '"';
+ end loop;
+
+ -- Normal case of identifier
+
+ else
+ -- Loop to output the name
+
+ -- This is not right wrt wide char encodings ??? ()
+
+ while TDef (SDef) in '0' .. '9'
+ or else TDef (SDef) >= 'A'
+ or else TDef (SDef) = ASCII.ESC
+ loop
+ Add_Char_To_Name_Buffer (TDef (SDef));
+ SDef := SDef + 1;
+ end loop;
+ end if;
+ end Write_Entity_Name;
end Exp_Intr;
projects / gcc.git / blobdiff