+2011-08-29 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch5.adb, sem_ch3.adb, a-cihama.adb, a-cihama.ads, exp_ch7.adb,
+ sem_ch5.adb, a-ciorse.adb, a-ciorse.ads, sem_ch12.adb, a-cidlli.adb,
+ a-cidlli.ads, sem_util.adb, sem_res.adb, gnat1drv.adb, a-except.adb,
+ a-except.ads, a-except-2005.ads, sem_ch4.adb, exp_disp.adb,
+ exp_aggr.adb, sem_ch13.adb, par-ch3.adb: Minor reformatting.
+
+2011-08-29 Tristan Gingold <gingold@adacore.com>
+
+ * s-auxdec-vms-alpha.adb: Add comments, remove some HT before labels.
+
+2011-08-29 Vadim Godunko <godunko@adacore.com>
+
+ * s-parint.ads: Minor comment clarification.
+
+2011-08-29 Vincent Celier <celier@adacore.com>
+
+ * prj.adb (Initialize): Make sure that new reserved words after Ada 95
+ may be used as identifiers.
+
+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * a-coinho.ads: Minor reformating.
+
2011-08-29 Ed Schonberg <schonberg@adacore.com>
* exp_ch5.adb (Expand_Iterator_Loop): Handle properly a loop over a
List_Iterator_Interfaces.Reversible_Iterator with record
Container : List_Access;
Node : Node_Access;
- end record;
+ end record;
- overriding function First (Object : Iterator) return Cursor;
- overriding function Last (Object : Iterator) return Cursor;
- overriding function Next (Object : Iterator; Position : Cursor)
- return Cursor;
- overriding function Previous (Object : Iterator; Position : Cursor)
- return Cursor;
+ overriding function First (Object : Iterator) return Cursor;
+
+ overriding function Last (Object : Iterator) return Cursor;
+
+ overriding function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+
+ overriding function Previous
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
-----------------------
-- Local Subprograms --
B := B - 1;
end Iterate;
- function Iterate (Container : List)
- return List_Iterator_Interfaces.Reversible_Iterator'class
+ function Iterate
+ (Container : List)
+ return List_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator := (Container'Unchecked_Access, Container.First);
begin
return It;
end Iterate;
- function Iterate (Container : List; Start : Cursor)
- return List_Iterator_Interfaces.Reversible_Iterator'class
+ function Iterate
+ (Container : List;
+ Start : Cursor)
+ return List_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator := (Container'Unchecked_Access, Start.Node);
begin
begin
if Position.Node = Position.Container.First then
return No_Element;
-
else
return (Object.Container, Position.Node.Prev);
end if;
------------------------------------------------------------------------------
with Ada.Iterator_Interfaces;
-with Ada.Streams; use Ada.Streams;
+with Ada.Streams; use Ada.Streams;
+
private with Ada.Finalization;
generic
pragma Preelaborate;
pragma Remote_Types;
- type List is tagged private
- with
+ type List is tagged private with
Constant_Indexing => Constant_Reference,
Variable_Indexing => Reference,
Default_Iterator => Iterate,
Empty_List : constant List;
No_Element : constant Cursor;
+
function Has_Element (Position : Cursor) return Boolean;
package List_Iterator_Interfaces is new
(Container : List;
Process : not null access procedure (Position : Cursor));
- function Iterate (Container : List)
+ function Iterate
+ (Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'class;
- function Iterate (Container : List; Start : Cursor)
+ function Iterate
+ (Container : List;
+ Start : Cursor)
return List_Iterator_Interfaces.Reversible_Iterator'class;
type Constant_Reference_Type
for Reference_Type'Read use Read;
function Constant_Reference
- (Container : List; Position : Cursor) -- SHOULD BE ALIASED
- return Constant_Reference_Type;
+ (Container : List;
+ Position : Cursor) -- SHOULD BE ALIASED ???
+ return Constant_Reference_Type;
function Reference
- (Container : List; Position : Cursor) -- SHOULD BE ALIASED
- return Reference_Type;
+ (Container : List;
+ Position : Cursor) -- SHOULD BE ALIASED ???
+ return Reference_Type;
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
type Iterator is new
Map_Iterator_Interfaces.Forward_Iterator with record
- Container : Map_Access;
- Node : Node_Access;
- end record;
+ Container : Map_Access;
+ Node : Node_Access;
+ end record;
overriding function First (Object : Iterator) return Cursor;
- overriding function Next (Object : Iterator; Position : Cursor)
- return Cursor;
+
+ overriding function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
-----------------------
-- Local Subprograms --
begin
if N = null then
return No_Element;
+ else
+ return Cursor'(Object.Container.all'Unchecked_Access, N);
end if;
-
- return Cursor'(Object.Container.all'Unchecked_Access, N);
end First;
----------
procedure Free (X : in out Node_Access) is
procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
begin
if X = null then
return;
begin
if Position.Node = null then
return No_Element;
-
else
return (Object.Container, Next (Position).Node);
end if;
-- Reference --
---------------
- function Constant_Reference (Container : Map; Key : Key_Type)
- return Constant_Reference_Type is
+ function Constant_Reference
+ (Container : Map;
+ Key : Key_Type) return Constant_Reference_Type
+ is
begin
return (Element =>
Container.Find (Key).Node.Element.all'Unrestricted_Access);
end Constant_Reference;
- function Reference (Container : Map; Key : Key_Type)
- return Reference_Type is
+ function Reference
+ (Container : Map;
+ Key : Key_Type) return Reference_Type
+ is
begin
return (Element =>
Container.Find (Key).Node.Element.all'Unrestricted_Access);
pragma Preelaborate;
pragma Remote_Types;
- type Map is tagged private
- with
+ type Map is tagged private with
Constant_Indexing => Constant_Reference,
Variable_Indexing => Reference,
Default_Iterator => Iterate,
type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
- Empty_Map : constant Map;
+ Empty_Map : constant Map;
-- Map objects declared without an initialization expression are
-- initialized to the value Empty_Map.
for Reference_Type'Read use Read;
function Constant_Reference
- (Container : Map; Key : Key_Type) -- SHOULD BE ALIASED
- return Constant_Reference_Type;
+ (Container : Map;
+ Key : Key_Type) -- SHOULD BE ALIASED ???
+ return Constant_Reference_Type;
function Reference (Container : Map; Key : Key_Type)
return Reference_Type;
type Iterator is new
Ordered_Set_Iterator_Interfaces.Reversible_Iterator with record
- Container : access constant Set;
- Node : Node_Access;
- end record;
+ Container : access constant Set;
+ Node : Node_Access;
+ end record;
overriding function First (Object : Iterator) return Cursor;
- overriding function Last (Object : Iterator) return Cursor;
- overriding function Next (Object : Iterator; Position : Cursor)
- return Cursor;
- overriding function Previous (Object : Iterator; Position : Cursor)
- return Cursor;
+
+ overriding function Last (Object : Iterator) return Cursor;
+
+ overriding function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+
+ overriding function Previous
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
-----------------------
-- Local Subprograms --
function First (Object : Iterator) return Cursor is
begin
return Cursor'(
- Object.Container.all'Unrestricted_Access, Object.Container.Tree.First);
+ Object.Container.all'Unrestricted_Access, Object.Container.Tree.First);
end First;
-------------------
begin
if Container.Tree.First = null then
raise Constraint_Error with "set is empty";
+ else
+ return Container.Tree.First.Element.all;
end if;
-
- return Container.Tree.First.Element.all;
end First_Element;
-----------
function Floor (Container : Set; Item : Element_Type) return Cursor is
Node : constant Node_Access :=
Element_Keys.Floor (Container.Tree, Item);
-
begin
if Node = null then
return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
-
- return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
----------
B := B - 1;
end Iterate;
- function Iterate (Container : Set)
- return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
+ function Iterate
+ (Container : Set)
+ return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator :=
(Container'Unchecked_Access, Container.Tree.First);
return It;
end Iterate;
- function Iterate (Container : Set; Start : Cursor)
- return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
+ function Iterate
+ (Container : Set;
+ Start : Cursor)
+ return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator := (Container'Unchecked_Access, Start.Node);
begin
begin
if Container.Tree.Last = null then
return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
end if;
-
- return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
end Last;
function Last (Object : Iterator) return Cursor is
begin
if Object.Container.Tree.Last = null then
return No_Element;
+ else
+ return Cursor'(
+ Object.Container.all'Unrestricted_Access,
+ Object.Container.Tree.Last);
end if;
-
- return Cursor'(
- Object.Container.all'Unrestricted_Access, Object.Container.Tree.Last);
end Last;
------------------
begin
if Container.Tree.Last = null then
raise Constraint_Error with "set is empty";
+ else
+ return Container.Tree.Last.Element.all;
end if;
-
- return Container.Tree.Last.Element.all;
end Last_Element;
----------
end;
end Next;
- function Next (Object : Iterator; Position : Cursor)
- return Cursor
+ function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor
is
pragma Unreferenced (Object);
begin
end;
end Previous;
- function Previous (Object : Iterator; Position : Cursor)
- return Cursor
+ function Previous
+ (Object : Iterator;
+ Position : Cursor) return Cursor
is
pragma Unreferenced (Object);
begin
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
- type Set is tagged private
- with
- Constant_Indexing => Constant_Reference,
- Variable_Indexing => Reference,
- Default_Iterator => Iterate,
- Iterator_Element => Element_Type;
+ type Set is tagged private with
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Reference,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
pragma Preelaborable_Initialization (Set);
Empty_Set : constant Set;
No_Element : constant Cursor;
+
function Has_Element (Position : Cursor) return Boolean;
package Ordered_Set_Iterator_Interfaces is new
Ada.Iterator_Interfaces (Cursor, Has_Element);
type Constant_Reference_Type
- (Element : not null access constant Element_Type) is
- private
- with
+ (Element : not null access constant Element_Type) is
+ private with
Implicit_Dereference => Element;
procedure Read
for Constant_Reference_Type'Write use Write;
function Constant_Reference
- (Container : Set; Position : Cursor)
- return Constant_Reference_Type;
+ (Container : Set;
+ Position : Cursor) return Constant_Reference_Type;
type Reference_Type (Element : not null access Element_Type) is private
with
(Container : Set;
Process : not null access procedure (Position : Cursor));
- function Iterate (Container : Set)
+ function Iterate
+ (Container : Set)
return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class;
- function Iterate (Container : Set; Start : Cursor)
+ function Iterate
+ (Container : Set;
+ Start : Cursor)
return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class;
generic
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S --
+-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S --
-- --
-- S p e c --
-- --
-- is already deferred.
function Triggered_By_Abort return Boolean;
- -- Determine whether the current exception (if exists) is an instance of
+ -- Determine whether the current exception (if it exists) is an instance of
-- Standard'Abort_Signal.
-----------------------
function Triggered_By_Abort return Boolean is
Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
-
begin
return Ex /= null
and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity;
-- abort is already deferred.
function Triggered_By_Abort return Boolean;
- -- Determine whether the current exception (if exists) is an instance of
+ -- Determine whether the current exception (if it exists) is an instance of
-- Standard'Abort_Signal.
-----------------------
-------------------------
function Top_Level_Aggregate (N : Node_Id) return Node_Id is
- Aggr : Node_Id := N;
+ Aggr : Node_Id;
begin
+ Aggr := N;
while Present (Parent (Aggr))
and then Nkind_In (Parent (Aggr), N_Component_Association,
N_Aggregate)
New_Reference_To (Iterator, Loc)))));
-- for Index in Array loop
- --
+
-- This case utilizes the already given iterator name
else
-- for Iterator in [reverse] Container'Range loop
-- Element : Component_Type renames Container (Iterator);
-- -- for the "of" form
- --
+
-- <original loop statements>
-- end loop;
if Of_Present (I_Spec) then
declare
- Default_Iter : constant Entity_Id :=
- Entity (
- Find_Aspect
- (Etype (Container), Aspect_Default_Iterator));
+ Default_Iter : constant Entity_Id :=
+ Entity
+ (Find_Aspect
+ (Etype (Container),
+ Aspect_Default_Iterator));
+
Container_Arg : Node_Id;
Ent : Entity_Id;
-- inherited from the scope of the parent.
if Base_Type (Etype (Container)) =
- Base_Type (Etype (First_Formal (Default_Iter)))
+ Base_Type (Etype (First_Formal (Default_Iter)))
then
Container_Arg := New_Copy_Tree (Container);
Container_Arg :=
Make_Type_Conversion (Loc,
Subtype_Mark =>
- New_Occurrence_Of (
- Etype (First_Formal (Default_Iter)), Loc),
+ New_Occurrence_Of
+ (Etype (First_Formal (Default_Iter)), Loc),
Expression => New_Copy_Tree (Container));
end if;
Decl :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
- Subtype_Mark =>
+ Subtype_Mark =>
New_Reference_To (Element_Type, Loc),
- Name =>
+ Name =>
Make_Indexed_Component (Loc,
- Prefix => Make_Selected_Component (Loc,
+ Prefix => Make_Selected_Component (Loc,
Prefix => New_Reference_To (Pack, Loc),
Selector_Name =>
Make_Identifier (Loc, Chars => Name_Element)),
Stats := New_List (
Make_Block_Statement (Loc,
- Declarations => New_List (Decl),
+ Declarations => New_List (Decl),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stats)));
-- For both iterator forms, add a call to the step operation to
-- advance the cursor. Generate:
- --
- -- Cursor := Iterator.Next (Cursor);
+
+ -- Cursor := Iterator.Next (Cursor);
+
-- or else
- -- Cursor := Next (Cursor);
+
+ -- Cursor := Next (Cursor);
declare
Rhs : Node_Id;
begin
Rhs :=
Make_Function_Call (Loc,
- Name =>
+ Name =>
Make_Selected_Component (Loc,
- Prefix => New_Reference_To (Iterator, Loc),
+ Prefix => New_Reference_To (Iterator, Loc),
Selector_Name => Make_Identifier (Loc, Name_Step)),
Parameter_Associations => New_List (
New_Reference_To (Cursor, Loc)));
Make_Iteration_Scheme (Loc,
Condition =>
Make_Function_Call (Loc,
- Name =>
+ Name =>
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Pack, Loc),
Selector_Name =>
-- Create the declarations for Iterator and cursor and insert then
-- before the source loop. Generate:
- --
+
-- I : Iterator_Type := Iterate (Container);
-- C : Pack.Cursor_Type := Container.[First | Last];
Decl2 :=
Make_Object_Declaration (Loc,
Defining_Identifier => Cursor,
- Object_Definition =>
+ Object_Definition =>
New_Occurrence_Of (Etype (Cursor), Loc),
-
- Expression =>
+ Expression =>
Make_Selected_Component (Loc,
- Prefix => New_Reference_To (Iterator, Loc),
+ Prefix => New_Reference_To (Iterator, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Init)));
if RTE_Available (RE_Raise_From_Controlled_Operation) then
Stmt :=
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To
(RTE (RE_Raise_From_Controlled_Operation), Loc),
Parameter_Associations =>
return
Make_If_Statement (Loc,
- Condition =>
+ Condition =>
Make_And_Then (Loc,
Left_Opnd => New_Reference_To (Raised_Id, Loc),
Right_Opnd =>
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Asynchronous_Select_Spec (Typ),
- Declarations =>
- New_List,
+ Specification => Make_Disp_Asynchronous_Select_Spec (Typ),
+ Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (Make_Assignment_Statement (Loc,
- Name => Make_Identifier (Loc, Name_uF),
+ Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_False, Loc)))));
end if;
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name => Make_Identifier (Loc, Name_uF),
+ Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_False, Loc)));
else
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name => Make_Identifier (Loc, Name_uF),
+ Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_False, Loc)));
end if;
return
Make_Subprogram_Body (Loc,
- Specification =>
+ Specification =>
Make_Disp_Asynchronous_Select_Spec (Typ),
- Declarations =>
- Decls,
+ Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Asynchronous_Select_Body;
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (Make_Assignment_Statement (Loc,
- Name => Make_Identifier (Loc, Name_uF),
+ Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_False, Loc)))));
end if;
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name => Make_Identifier (Loc, Name_uF),
+ Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_False, Loc)));
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name => Make_Identifier (Loc, Name_uC),
+ Name => Make_Identifier (Loc, Name_uC),
Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
end if;
return
Make_Subprogram_Body (Loc,
- Specification =>
+ Specification =>
Make_Disp_Conditional_Select_Spec (Typ),
- Declarations =>
- Decls,
+ Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Conditional_Select_Body;
New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- New_List (Make_Assignment_Statement (Loc,
- Name => Make_Identifier (Loc, Name_uF),
- Expression => New_Reference_To (Standard_False, Loc)))));
+ New_List (
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)))));
end if;
if Is_Concurrent_Record_Type (Typ) then
Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uI),
- Object_Definition =>
- New_Reference_To (Standard_Integer, Loc)));
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition => New_Reference_To (Standard_Integer, Loc)));
-- Generate:
-- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
else
Tag_Node :=
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Typ, Loc),
+ Prefix => New_Reference_To (Typ, Loc),
Attribute_Name => Name_Tag);
end if;
Name => Make_Identifier (Loc, Name_uI),
Expression =>
Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
+ Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations =>
New_List (
Tag_Node,
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name => Make_Identifier (Loc, Name_uF),
+ Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_False, Loc)));
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name => Make_Identifier (Loc, Name_uC),
+ Name => Make_Identifier (Loc, Name_uC),
Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
end if;
return
Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Timed_Select_Spec (Typ),
- Declarations =>
- Decls,
+ Specification => Make_Disp_Timed_Select_Spec (Typ),
+ Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Timed_Select_Body;
-- We would prefer to suppress the expansion of tagged types and
-- dispatching calls, so that one day GNATprove can handle them
-- directly. Unfortunately, this is causing problems on H513-015, so
- -- keep this expansion for the time being.
+ -- keep this expansion for the time being. ???
Tagged_Type_Expansion := True;
end if;
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
- -- AI95-406 makes "aliased" legal (and useless) in this context.
+ -- AI95-406 makes "aliased" legal (and useless) in this context so
+ -- followintg code which used to be needed is commented out.
-- if Aliased_Present then
-- Error_Msg_SP ("ALIASED not allowed here");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
- -- AI95-406 makes "aliased" legal (and useless) here.
+ -- AI95-406 makes "aliased" legal (and useless) here, so the
+ -- following code which used to be required is commented out.
-- if Aliased_Present then
-- Error_Msg_SP ("ALIASED not allowed here");
------------------------------------------------------------------------------
with Debug;
+with Opt;
with Osint; use Osint;
with Output; use Output;
with Prj.Attr;
Prj.Attr.Initialize;
+ -- Make sure that new reserved words after Ada 95 may be used as
+ -- identifiers.
+
+ Opt.Ada_Version := Opt.Ada_95;
+
Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
-- --
-- B o d y --
-- --
--- 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- --
begin
System.Machine_Code.Asm
(
- "lda $16, %3" & LF & HT &
+ "lda $16, %3" & LF & HT & -- Address of Bit
"mb" & LF & HT &
- "sll $16, 3, $18 " & LF & HT &
- "bis $31, 1, %1" & LF & HT &
- "and $18, 63, $19" & LF & HT &
- "bic $18, 63, $18" & LF & HT &
- "sra $18, 3, $18" & LF & HT &
- "bis $31, %4, $17" & LF & HT &
- "sll %1, $19, $19" & LF & HT &
+ "sll $16, 3, $18 " & LF & HT & -- Byte address to bit address
+ "bis $31, 1, %1" & LF & HT & -- Set temp to 1 for the sll
+ "and $18, 63, $19" & LF & HT & -- Quadword bit offset
+ "bic $18, 63, $18" & LF & HT & -- Quadword bit address
+ "sra $18, 3, $18" & LF & HT & -- Quadword address
+ "bis $31, %4, $17" & LF & HT & -- Retry_Count -> $17
+ "sll %1, $19, $19" & LF & -- $19 = 1 << bit_offset
"1:" & LF & HT &
- "ldq_l %2, 0($18)" & LF & HT &
- "and %2, $19, %1" & LF & HT &
- "bis %2, $19, %2" & LF & HT &
- "stq_c %2, 0($18)" & LF & HT &
- "beq %2, 2f" & LF & HT &
- "cmovne %1, 1, %1" & LF & HT &
- "br 3f" & LF & HT &
+ "ldq_l %2, 0($18)" & LF & HT & -- Load & lock
+ "and %2, $19, %1" & LF & HT & -- Previous value -> %1
+ "bis %2, $19, %2" & LF & HT & -- Set Bit
+ "stq_c %2, 0($18)" & LF & HT & -- Store conditional
+ "beq %2, 2f" & LF & HT & -- Goto 2: if failed
+ "cmovne %1, 1, %1" & LF & HT & -- Set Old_Bit
+ "br 3f" & LF &
"2:" & LF & HT &
- "subq $17, 1, $17" & LF & HT &
- "bgt $17, 1b" & LF & HT &
+ "subq $17, 1, $17" & LF & HT & -- Retry_Count - 1
+ "bgt $17, 1b" & LF & -- Retry ?
"3:" & LF & HT &
"mb" & LF & HT &
"trapb",
begin
System.Machine_Code.Asm
(
- "mb" & LF & HT &
+ "mb" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"addl $1, %2, $0" & LF & HT &
System.Machine_Code.Asm
(
"mb" & LF & HT &
- "bis $31, %5, $17" & LF & HT &
+ "bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"addl $1, %4, $0" & LF & HT &
"stl_c $0, %3" & LF & HT &
- "beq $0, 2f" & LF & HT &
+ "beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stl $1, %1" & LF & HT &
- "br 4f" & LF & HT &
+ "br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
- "br 3b" & LF & HT &
+ "br 3b" & LF &
"4:",
Outputs => (Aligned_Integer'Asm_Output ("=m", To),
Integer'Asm_Output ("=m", Old_Value),
begin
System.Machine_Code.Asm
(
- "mb" & LF & HT &
+ "mb" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"addq $1, %2, $0" & LF & HT &
System.Machine_Code.Asm
(
"mb" & LF & HT &
- "bis $31, %5, $17" & LF & HT &
+ "bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"addq $1, %4, $0" & LF & HT &
"stq_c $0, %3" & LF & HT &
- "beq $0, 2f" & LF & HT &
+ "beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stq $1, %1" & LF & HT &
- "br 4f" & LF & HT &
+ "br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
- "br 3b" & LF & HT &
+ "br 3b" & LF &
"4:",
Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To),
Long_Integer'Asm_Output ("=m", Old_Value),
begin
System.Machine_Code.Asm
(
- "mb" & LF & HT &
+ "mb" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"and $1, %2, $0" & LF & HT &
System.Machine_Code.Asm
(
"mb" & LF & HT &
- "bis $31, %5, $17" & LF & HT &
+ "bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"and $1, %4, $0" & LF & HT &
"stl_c $0, %3" & LF & HT &
- "beq $0, 2f" & LF & HT &
+ "beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stl $1, %1" & LF & HT &
- "br 4f" & LF & HT &
+ "br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
- "br 3b" & LF & HT &
+ "br 3b" & LF &
"4:",
Outputs => (Aligned_Integer'Asm_Output ("=m", To),
Integer'Asm_Output ("=m", Old_Value),
begin
System.Machine_Code.Asm
(
- "mb" & LF & HT &
+ "mb" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"and $1, %2, $0" & LF & HT &
System.Machine_Code.Asm
(
"mb" & LF & HT &
- "bis $31, %5, $17" & LF & HT &
+ "bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"and $1, %4, $0" & LF & HT &
"stq_c $0, %3" & LF & HT &
- "beq $0, 2f" & LF & HT &
+ "beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stq $1, %1" & LF & HT &
- "br 4f" & LF & HT &
+ "br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
- "br 3b" & LF & HT &
+ "br 3b" & LF &
"4:",
Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To),
Long_Integer'Asm_Output ("=m", Old_Value),
begin
System.Machine_Code.Asm
(
- "mb" & LF & HT &
+ "mb" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"bis $1, %2, $0" & LF & HT &
System.Machine_Code.Asm
(
"mb" & LF & HT &
- "bis $31, %5, $17" & LF & HT &
+ "bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"bis $1, %4, $0" & LF & HT &
"stl_c $0, %3" & LF & HT &
- "beq $0, 2f" & LF & HT &
+ "beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stl $1, %1" & LF & HT &
- "br 4f" & LF & HT &
+ "br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
- "br 3b" & LF & HT &
+ "br 3b" & LF &
"4:",
Outputs => (Aligned_Integer'Asm_Output ("=m", To),
Integer'Asm_Output ("=m", Old_Value),
begin
System.Machine_Code.Asm
(
- "mb" & LF & HT &
+ "mb" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"bis $1, %2, $0" & LF & HT &
System.Machine_Code.Asm
(
"mb" & LF & HT &
- "bis $31, %5, $17" & LF & HT &
+ "bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"bis $1, %4, $0" & LF & HT &
"stq_c $0, %3" & LF & HT &
- "beq $0, 2f" & LF & HT &
+ "beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stq $1, %1" & LF & HT &
- "br 4f" & LF & HT &
+ "br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
- "br 3b" & LF & HT &
+ "br 3b" & LF &
"4:",
Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To),
Long_Integer'Asm_Output ("=m", Old_Value),
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
PCS_Version : constant := 1;
-- Version of the PCS API (for Exp_Dist consistency check).
- -- This version number is matched against Gnatvsn.PCS_Version_Number to
- -- ensure that the versions of Exp_Dist and the PCS are consistent.
+ -- This version number is matched against corresponding element of
+ -- Exp_Dist.PCS_Version_Number to ensure that the versions of Exp_Dist and
+ -- the PCS are consistent.
-- RCI receiving stubs contain a table of descriptors for
-- all user subprograms exported by the unit.
if Subp /= Any_Id then
- -- Subprogram found, generate reference to it.
+ -- Subprogram found, generate reference to it
Set_Entity (Def, Subp);
Generate_Reference (Subp, Def);
A_Id = Aspect_Default_Iterator or else
A_Id = Aspect_Iterator_Element
then
- -- Make type unfrozen before analysis, to prevent spurious
- -- errors about late attributes.
+ -- Make type unfrozen before analysis, to prevent spurious errors
+ -- about late attributes.
Set_Is_Frozen (Ent, False);
Analyze (End_Decl_Expr);
Set_Has_Private_Declaration (Prev);
Set_Has_Private_Declaration (Id);
- -- Preserve aspect and iterator flags, that may have been
- -- set on the partial view.
+ -- Preserve aspect and iterator flags that may have been set on
+ -- the partial view.
Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id));
Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id));
Iterator : Node_Id;
begin
+ -- Analyze construct with expansion disabled, because it will be
+ -- rewritten as a loop during expansion.
+
Expander_Mode_Save_And_Set (False);
Check_SPARK_Restriction ("quantified expression is not allowed", N);
Set_Parent (Iterator, N);
Analyze_Iteration_Scheme (Iterator);
- -- The loop specification may have been converted into an
- -- iterator specification during its analysis. Update the
- -- quantified node accordingly.
+ -- The loop specification may have been converted into an iterator
+ -- specification during its analysis. Update the quantified node
+ -- accordingly.
if Present (Iterator_Specification (Iterator)) then
Set_Iterator_Specification
Set_Parent (D_Copy, Parent (DS));
Pre_Analyze_Range (D_Copy);
- -- Ada2012 : if the domain of iteration is a function call,
+ -- Ada2012: If the domain of iteration is a function call,
-- it is the new iterator form.
-- We have also implemented the shorter form : for X in S
- -- for Alfa use. In this case the attributes Old and Result
- -- must be treated as entity names over which iterators are
- -- legal.
+ -- for Alfa use. In this case, 'Old and 'Result must be
+ -- treated as entity names over which iterators are legal.
if Nkind (D_Copy) = N_Function_Call
or else
(ALFA_Mode
- and then (Nkind (D_Copy) = N_Attribute_Reference
- and then
- (Attribute_Name (D_Copy) = Name_Result
+ and then (Nkind (D_Copy) = N_Attribute_Reference
+ and then
+ (Attribute_Name (D_Copy) = Name_Result
or else Attribute_Name (D_Copy) = Name_Old)))
-
or else
(Is_Entity_Name (D_Copy)
and then not Is_Type (Entity (D_Copy)))
Set_Loop_Parameter_Specification (N, Empty);
Analyze_Iterator_Specification (I_Spec);
- -- In a generic context, analyze the original
- -- domain of iteration, for name capture.
+ -- In a generic context, analyze the original domain
+ -- of iteration, for name capture.
if not Expander_Active then
Analyze (DS);
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Relocate_Node (Iter_Name));
- Insert_Actions
- (Parent (Parent (N)), New_List (Decl));
+ Insert_Actions (Parent (Parent (N)), New_List (Decl));
Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
Set_Etype (Id, Typ);
Set_Etype (Name (N), Typ);
end;
- else
-
- -- Container is an entity or an array with uncontrolled components,
- -- or else it is a container iterator given by a function call,
- -- typically called Iterate in the case of predefined containers,
- -- even though Iterate is not a reserved name. What matter is that
- -- the return type of the function is an iterator type.
+ -- Container is an entity or an array with uncontrolled components, or
+ -- else it is a container iterator given by a function call, typically
+ -- called Iterate in the case of predefined containers, even though
+ -- Iterate is not a reserved name. What matter is that the return type
+ -- of the function is an iterator type.
+ else
Analyze (Iter_Name);
+
if Nkind (Iter_Name) = N_Function_Call then
declare
C : constant Node_Id := Name (Iter_Name);
end if;
end;
- else
-
- -- domain of iteration is not overloaded.
+ -- Domain of iteration is not overloaded
+ else
Resolve (Iter_Name, Etype (Iter_Name));
end if;
end if;
Set_Etype (Def_Id, Etype (First_Index (Typ)));
end if;
- -- Check for type error in iterator.
+ -- Check for type error in iterator
elsif Typ = Any_Type then
return;
if Of_Present (N) then
- -- The type of the loop variable is the Iterator_Element
- -- aspect of the container type.
+ -- The type of the loop variable is the Iterator_Element aspect of
+ -- the container type.
Set_Etype (Def_Id,
Entity (Find_Aspect (Typ, Aspect_Iterator_Element)));
else
- -- The result type of Iterate function is the classwide type
- -- of the interface parent. We need the specific Cursor type
- -- defined in the container package.
+ -- The result type of Iterate function is the classwide type of
+ -- the interface parent. We need the specific Cursor type defined
+ -- in the container package.
Ent := First_Entity (Scope (Typ));
while Present (Ent) loop
end if;
end if;
- -- Report a simple error: if the designated object is a local task,
+ -- Report a simple error: if the designated object is a local task,
-- its body has not been seen yet, and its activation will fail an
-- elaboration check.
if Is_Class_Wide_Type (Typ)
and then
(Chars (Etype (Typ)) = Name_Forward_Iterator
- or else Chars (Etype (Typ)) = Name_Reversible_Iterator)
+ or else
+ Chars (Etype (Typ)) = Name_Reversible_Iterator)
and then
Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Etype (Typ))))
then
return True;
- elsif not Is_Tagged_Type (Typ)
- or else not Is_Derived_Type (Typ)
- then
+ elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
return False;
else
end if;
end Is_Iterator;
- ----------------------------
- -- Is_Reversible_Iterator --
- ----------------------------
-
- function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
- Ifaces_List : Elist_Id;
- Iface_Elmt : Elmt_Id;
- Iface : Entity_Id;
-
- begin
- if Is_Class_Wide_Type (Typ)
- and then Chars (Etype (Typ)) = Name_Reversible_Iterator
- and then
- Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
- then
- return True;
-
- elsif not Is_Tagged_Type (Typ)
- or else not Is_Derived_Type (Typ)
- then
- return False;
- else
-
- Collect_Interfaces (Typ, Ifaces_List);
-
- Iface_Elmt := First_Elmt (Ifaces_List);
- while Present (Iface_Elmt) loop
- Iface := Node (Iface_Elmt);
- if Chars (Iface) = Name_Reversible_Iterator
- and then
- Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Iface)))
- then
- return True;
- end if;
-
- Next_Elmt (Iface_Elmt);
- end loop;
-
- end if;
- return False;
- end Is_Reversible_Iterator;
-
------------
-- Is_LHS --
------------
return False;
end Is_Renamed_Entry;
+ ----------------------------
+ -- Is_Reversible_Iterator --
+ ----------------------------
+
+ function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
+ Ifaces_List : Elist_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface : Entity_Id;
+
+ begin
+ if Is_Class_Wide_Type (Typ)
+ and then Chars (Etype (Typ)) = Name_Reversible_Iterator
+ and then
+ Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
+ then
+ return True;
+
+ elsif not Is_Tagged_Type (Typ)
+ or else not Is_Derived_Type (Typ)
+ then
+ return False;
+
+ else
+ Collect_Interfaces (Typ, Ifaces_List);
+
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+ if Chars (Iface) = Name_Reversible_Iterator
+ and then
+ Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Iface)))
+ then
+ return True;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end if;
+
+ return False;
+ end Is_Reversible_Iterator;
+
----------------------
-- Is_Selector_Name --
----------------------
projects / gcc.git / commitdiff