+2011-08-05 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch3.adb, gnatcmd.adb, switch-c.adb, exp_attr.adb, make.adb,
+ bindgen.adb, einfo.adb, sem_ch12.adb, sem_attr.adb, a-fihema.adb,
+ a-fihema.ads, sem_elab.adb, sem_elab.ads, aspects.adb, opt.ads,
+ prj-conf.adb, sem_ch13.adb, s-ficobl.ads: Minor reformatting
+
+2011-08-05 Bob Duff <duff@adacore.com>
+
+ * a-stunau.ads, g-spipat.adb: Update comments.
+
2011-08-05 Bob Duff <duff@adacore.com>
* a-fihema.ads: Minor comment fix.
package body Ada.Finalization.Heap_Management is
- Header_Size : constant Storage_Count := Node'Size / Storage_Unit;
+ Header_Size : constant Storage_Count := Node'Size / Storage_Unit;
-- Size of the header in bytes. Added to Storage_Size requested by
-- Allocate/Deallocate to determine the Storage_Size passed to the
-- underlying pool.
N.Prev := L;
Unlock_Task.all;
+
-- Note: no need to unlock in case of exceptions; the above code cannot
-- raise any.
end Attach;
N_Ptr : Node_Ptr;
begin
- -- Move the address from the object to the beginning of the list
- -- header.
+ -- Move address from the object to beginning of the list header
N_Addr := Addr - Header_Offset;
------------
procedure Detach (N : Node_Ptr) is
+
+ -- N must be attached to some list
+
pragma Assert (N.Next /= null and then N.Prev /= null);
- -- It must be attached to some list
procedure Null_Out_Pointers;
-- Set Next/Prev pointer of N to null (for debugging)
N.Prev := null;
end Null_Out_Pointers;
+ -- Start of processing for Detach
+
begin
Lock_Task.all;
-- Note: no need to unlock in case of exceptions; the above code cannot
-- raise any.
- pragma Debug (Null_Out_Pointers);
-- No need to null out the pointers, except that it makes pcol easier to
-- understand.
+
+ pragma Debug (Null_Out_Pointers);
end Detach;
--------------
-- to go away.
while Curr_Ptr /= Collection.Objects'Unchecked_Access loop
+
-- ??? Kludge: Don't do anything until the proper place to set
-- primitive Finalize_Address has been determined.
if Collection.Finalize_Address /= null then
declare
Object_Address : constant Address :=
- Curr_Ptr.all'Address + Header_Offset;
+ Curr_Ptr.all'Address + Header_Offset;
-- Get address of object from address of header
begin
procedure pcol (Collection : Finalization_Collection) is
Head : constant Node_Ptr := Collection.Objects'Unrestricted_Access;
- -- "Unrestricted", because we're evilly getting access-to-variable of a
- -- constant! OK for debugging code.
+ -- "Unrestricted", because we are getting access-to-variable of a
+ -- constant! Normally worrisome, this is OK for debugging code.
Head_Seen : Boolean := False;
N_Ptr : Node_Ptr;
Put_Line (Address_Image (Collection'Address));
Put ("Base_Pool : ");
+
if Collection.Base_Pool = null then
Put_Line (" null");
else
end if;
Put ("Fin_Addr : ");
+
if Collection.Finalize_Address = null then
Put_Line ("null");
else
-- (dummy head) - present if dummy head
N_Ptr := Head;
-
while N_Ptr /= null loop -- Should never be null; we being defensive
Put_Line ("V");
end if;
Put ("| Prev: ");
+
if N_Ptr.Prev = null then
Put_Line ("null");
else
end if;
Put ("| Next: ");
+
if N_Ptr.Next = null then
Put_Line ("null");
else
overriding procedure Finalize
(Collection : in out Finalization_Collection);
- -- Traverse the objects of Collection, invoking Finalize_Address on each of
- -- them.
+ -- Traverse objects of Collection, invoking Finalize_Address on each one
overriding procedure Initialize
(Collection : in out Finalization_Collection);
type Node_Ptr is access all Node;
pragma No_Strict_Aliasing (Node_Ptr);
- type Node is record
- -- This should really be limited, but we can see the full view of
- -- Limited_Controlled, which is NOT limited. Note that default
- -- initialization does not happen for this type (these pointers will not
- -- be automatically set to null), because of the games we're playing
- -- with address arithmetic.
+ -- The following record type should really be limited, but we can see the
+ -- full view of Limited_Controlled, which is NOT limited. Note that default
+ -- initialization does not happen for this type (the pointers will not be
+ -- automatically set to null), because of the games we're playing with
+ -- address arithmetic.
+ type Node is record
Prev : Node_Ptr;
Next : Node_Ptr;
end record;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
-- referenced string returned by this call is always one, so the actual
-- string data is always accessible as S (1 .. L).
- procedure Set_String (UP : out Unbounded_String; S : String)
- renames Set_Unbounded_String;
- -- This function is simply a renaming of the new Ada 2005 function as shown
- -- above. It is provided for historical reasons, but should be removed at
- -- this stage???
-
procedure Set_String (UP : in out Unbounded_String; S : String_Access);
pragma Inline (Set_String);
-- This version of Set_Unbounded_String takes a string access value, rather
-- Same as Set_Aspect_Specifications, but does not contain the assertion
-- that checks that N does not already have aspect specifications. This
-- subprogram is supposed to be used as a part of Tree_Read. When reading
- -- the tree we first read nodes with their basic properties (as
- -- Atree.Tree_Read), this includes reading the Has_Aspects flag for each
- -- node, then we reed all the list tables and only after that we call
- -- Tree_Read for Aspects. That is, when reading the tree, the list of
- -- aspects is attached to the node that already has Has_Aspects flag set
- -- ON
+ -- tree, first read nodes with their basic properties (as Atree.Tree_Read),
+ -- this includes reading the Has_Aspects flag for each node, then we reed
+ -- all the list tables and only after that we call Tree_Read for Aspects.
+ -- That is, when reading the tree, the list of aspects is attached to the
+ -- node that already has Has_Aspects flag set ON.
------------------------------------------
-- Hash Table for Aspect Specifications --
procedure Gen_CodePeer_Wrapper is
Callee_Name : constant String := "Ada_Main_Program";
+
begin
if ALIs.Table (ALIs.First).Main_Program = Proc then
WBI (" procedure " & CodePeer_Wrapper_Name & " is ");
procedure Gen_Main is
begin
if not No_Main_Subprogram then
+
-- To call the main program, we declare it using a pragma Import
-- Ada with the right link name.
if ALIs.Table (ALIs.First).Main_Program = Func then
WBI (" function Ada_Main_Program return Integer;");
-
else
WBI (" procedure Ada_Main_Program;");
end if;
end if;
if Bind_Main_Program
- and then not Suppress_Standard_Library_On_Target
- and then not CodePeer_Mode
+ and not Suppress_Standard_Library_On_Target
+ and not CodePeer_Mode
then
WBI (" SEH : aliased array (1 .. 2) of Integer;");
WBI ("");
-- this variable at any level of optimization.
if Bind_Main_Program and not CodePeer_Mode then
- WBI
- (" Ensure_Reference : aliased System.Address := " &
- "Ada_Main_Program_Name'Address;");
+ WBI (" Ensure_Reference : aliased System.Address := " &
+ "Ada_Main_Program_Name'Address;");
WBI (" pragma Volatile (Ensure_Reference);");
WBI ("");
end if;
-- Is_Safe_To_Reevaluate Flag249
-- Has_Predicates Flag250
+ -- (Has_Implicit_Dereference) Flag251
-- Is_Processed_Transient Flag252
-- Is_Postcondition_Proc Flag253
- -- (Has_Implicit_Dereference) Flag251
-- (unused) Flag254
-----------------------
case Id is
- -- Attributes related to Ada2012 iterators (Placeholder)
+ -- Attributes related to Ada2012 iterators (placeholder ???)
- when Attribute_Constant_Indexing => null;
- when Attribute_Default_Iterator => null;
+ when Attribute_Constant_Indexing => null;
+ when Attribute_Default_Iterator => null;
when Attribute_Implicit_Dereference => null;
- when Attribute_Iterator_Element => null;
- when Attribute_Variable_Indexing => null;
+ when Attribute_Iterator_Element => null;
+ when Attribute_Variable_Indexing => null;
------------
-- Access --
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2010, AdaCore --
+-- Copyright (C) 1998-2011, AdaCore --
-- --
-- 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- --
begin
if Node_OnM.Pcode = PC_Assign_OnM then
- Set_String (Node_OnM.VP.all, Subject (Start .. Stop));
+ Set_Unbounded_String
+ (Node_OnM.VP.all, Subject (Start .. Stop));
elsif Node_OnM.Pcode = PC_Write_OnM then
Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
-- Assign immediate. This node performs the actual assignment
when PC_Assign_Imm =>
- Set_String
+ Set_Unbounded_String
(Node.VP.all,
Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
Pop_Region;
begin
if Node_OnM.Pcode = PC_Assign_OnM then
- Set_String (Node_OnM.VP.all, Subject (Start .. Stop));
+ Set_Unbounded_String
+ (Node_OnM.VP.all, Subject (Start .. Stop));
Dout
(Img (Stack (S).Node) &
"deferred assignment of " &
Dout
(Img (Node) & "executing immediate assignment of " &
Image (Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)));
- Set_String
+ Set_Unbounded_String
(Node.VP.all,
Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
Pop_Region;
Close (File);
end if;
+ -- Don't crash if it is not possible to delete or close the file,
+ -- just ignore the situation.
+
exception
- -- Don't crash if it is not possible to delete or close the file
when others =>
null;
end;
end if;
end if;
- -- Put the object directories in ADA_OBJECTS_PATH.
+ -- Put the object directories in ADA_OBJECTS_PATH
Prj.Env.Set_Ada_Paths
(Main_Project,
-- Also forces generation of tree file if -gnatt is also set.
Disable_ALI_File : Boolean := False;
- -- GNAT2WHY
+ -- GNAT
-- Disable generation of ALI file
Force_Checking_Of_Elaboration_Flags : Boolean := False;
if Subdirs /= null then
Add_Char_To_Name_Buffer (Directory_Separator);
- Add_Str_To_Name_Buffer (Subdirs.all);
+ Add_Str_To_Name_Buffer (Subdirs.all);
end if;
for J in 1 .. Name_Len loop
procedure Check_RTS_Switches is
Switch_Array : Array_Element;
-
Switch_List : String_List_Id := Nil_String;
Switch : String_Element;
-
Lang : Name_Id;
Lang_Last : Positive;
-- Indicates sharing status of file, see description of type above
Access_Method : Character;
- -- Set to 'Q', 'S', 'T, 'D' for Sequential_IO, Stream_IO, Text_IO,
+ -- Set to 'Q', 'S', 'T', 'D' for Sequential_IO, Stream_IO, Text_IO,
-- Direct_IO file (used to validate file sharing request).
Next : AFCB_Ptr;
case Attr_Id is
- -- Attributes related to Ada2012 iterators (Placeholder).
+ -- Attributes related to Ada2012 iterators (placeholder ???)
- when Attribute_Constant_Indexing => null;
- when Attribute_Default_Iterator => null;
+ when Attribute_Constant_Indexing => null;
+ when Attribute_Default_Iterator => null;
when Attribute_Implicit_Dereference => null;
- when Attribute_Iterator_Element => null;
- when Attribute_Variable_Indexing => null;
+ when Attribute_Iterator_Element => null;
+ when Attribute_Variable_Indexing => null;
------------------
-- Abort_Signal --
-- test Static as required in cases where it makes a difference.
-- In the case where Static is not set, we do know that all the
- -- expressions present are at least known at compile time (we
- -- assumed above that if this was not the case, then there was
- -- no hope of static evaluation). However, we did not require
- -- that the bounds of the prefix type be compile time known,
- -- let alone static). That's because there are many attributes
- -- that can be computed at compile time on non-static subtypes,
- -- even though such references are not static expressions.
+ -- expressions present are at least known at compile time (we assumed
+ -- above that if this was not the case, then there was no hope of static
+ -- evaluation). However, we did not require that the bounds of the
+ -- prefix type be compile time known, let alone static). That's because
+ -- there are many attributes that can be computed at compile time on
+ -- non-static subtypes, even though such references are not static
+ -- expressions.
case Id is
- -- Attributes related to Ada2012 iterators (Placeholder).
+ -- Attributes related to Ada2012 iterators (placeholder ???)
- when Attribute_Constant_Indexing => null;
- when Attribute_Default_Iterator => null;
+ when Attribute_Constant_Indexing => null;
+ when Attribute_Default_Iterator => null;
when Attribute_Implicit_Dereference => null;
- when Attribute_Iterator_Element => null;
- when Attribute_Variable_Indexing => null;
+ when Attribute_Iterator_Element => null;
+ when Attribute_Variable_Indexing => null;
--------------
-- Adjacent --
while Nkind (Gen_Name) = N_Expanded_Name loop
Gen_Name := Prefix (Gen_Name);
end loop;
+
if Chars (Gen_Name) = Chars (Pack_Id) then
Error_Msg_NE
("& is hidden within declaration of formal package",
-- The formals for which associations are provided are not visible
-- outside of the formal package. The others are still declared by a
-- formal parameter declaration.
+
-- If there are no associations, the only local entity to hide is the
-- generated package renaming itself.
begin
E := First_Entity (Formal);
while Present (E) loop
-
if Associations
and then not Is_Generic_Formal (E)
then
Delay_Required := False;
- -- Aspects related to container iterators.
+ -- Aspects related to container iterators (fill in later???)
when Aspect_Constant_Indexing |
Aspect_Default_Iterator |
null;
when Aspect_Implicit_Dereference =>
-
if not Is_Type (E)
or else not Has_Discriminants (E)
then
Set_Has_Implicit_Dereference (Disc);
goto Continue;
end if;
+
Next_Discriminant (Disc);
end loop;
--------------------------
-- Implicit_Dereference --
--------------------------
+
when Attribute_Implicit_Dereference =>
- -- Legality checks already performed above.
- null; -- TBD
+
+ -- Legality checks already performed above
+
+ null; -- TBD???
-----------
-- Input --
Aspect_Value_Size =>
T := Any_Integer;
+ -- Following to be done later ???
+
when Aspect_Constant_Indexing |
Aspect_Default_Iterator |
Aspect_Iterator_Element |
-- AI05-0068: report if there is an overriding
-- non-abstract subprogram that is invisible.
+
if Is_Hidden (E)
and then not Is_Abstract_Subprogram (E)
then
Error_Msg_NE
- ("\& subprogram# is not visible",
- T, Subp);
+ ("\& subprogram# is not visible",
+ T, Subp);
else
Error_Msg_NE
procedure Check_Elab_Call
(N : Node_Id;
Outer_Scope : Entity_Id := Empty;
- In_Init_Proc : Boolean := False)
+ In_Init_Proc : Boolean := False)
is
Ent : Entity_Id;
P : Node_Id;
procedure Check_Elab_Call
(N : Node_Id;
Outer_Scope : Entity_Id := Empty;
- In_Init_Proc : Boolean := False);
+ In_Init_Proc : Boolean := False);
-- Check a call for possible elaboration problems. The node N is either
-- an N_Function_Call or N_Procedure_Call_Statement node. The Outer_Scope
-- argument indicates whether this is an outer level call from Sem_Res
("-gnatZ is no longer supported: consider using --RTS=zcx");
-- Note on language version switches: whenever a new language
- -- version switch is added, procedure
- -- Switch.M.Normalize_Compiler_Switches must be updated.
+ -- version switch is added, Switch.M.Normalize_Compiler_Switches
+ -- must be updated.
-- Processing for 83 switch
projects / gcc.git / commitdiff