+2012-12-05 Yannick Moy <moy@adacore.com>
+
+ * urealp.ads: Minor rewording.
+
+2012-12-05 Yannick Moy <moy@adacore.com>
+
+ * aspects.ads (No_Duplicates_Allowed): Forbid use of duplicate
+ Contract_Cases aspects.
+ * sem_prag.adb (Analyze_Pragma/Pragma_Contract_Case): Rename
+ POST_CASE into CONTRACT_CASE in both grammar and code, to be
+ consistent with current language definition. Issue a more precise
+ error message when the pragma duplicates another pragma or aspect.
+
+2012-12-05 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Add processing
+ for attribute Update.
+ (Expand_Update_Attribute): New routine.
+ * par-ch4.adb (P_Name): The sole expression of attribute Update
+ is an aggregate, parse it accordingly.
+ * sem_attr.adb (Analyze_Attribute): Verify the legality of
+ attribute Update.
+ (Eval_Attribute): Attribute Update does not
+ need evaluation because it is never static.
+ * snames.ads-tmpl: Add Name_Update to the list of special names
+ recognized by the compiler. Add an Attribute_Id for Update.
+
+2012-12-05 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_util.adb (Remove_Side_Effects): For purposes of removing
+ side effects, qualified expressions do not receive a special
+ treatment, even though in Ada 2012 they are defined as object
+ references.
+
+2012-12-05 Thomas Quinot <quinot@adacore.com>
+
+ * par-ch3.adb: Minor reformatting.
+
2012-12-05 Thomas Quinot <quinot@adacore.com>
* exp_dist.adb (Build_From_Any_Call, Build_To_Any_Call,
No_Duplicates_Allowed : constant array (Aspect_Id) of Boolean :=
(Aspect_Contract_Case => False,
- Aspect_Contract_Cases => False,
Aspect_Test_Case => False,
others => True);
-- Handles expansion of Pred or Succ attributes for case of non-real
-- operand with overflow checking required.
+ procedure Expand_Update_Attribute (N : Node_Id);
+ -- Handle the expansion of attribute Update
+
function Get_Index_Subtype (N : Node_Id) return Entity_Id;
-- Used for Last, Last, and Length, when the prefix is an array type.
-- Obtains the corresponding index subtype.
Analyze_And_Resolve (N, Typ);
end UET_Address;
+ ------------
+ -- Update --
+ ------------
+
+ when Attribute_Update =>
+ Expand_Update_Attribute (N);
+
---------------
-- VADS_Size --
---------------
end if;
end Expand_Pred_Succ;
+ -----------------------------
+ -- Expand_Update_Attribute --
+ -----------------------------
+
+ procedure Expand_Update_Attribute (N : Node_Id) is
+ procedure Process_Component_Or_Element_Update
+ (Temp : Entity_Id;
+ Comp : Node_Id;
+ Expr : Node_Id;
+ Typ : Entity_Id);
+ -- Generate the statements necessary to update a single component or an
+ -- element of the prefix. The code is inserted before the attribute N.
+ -- Temp denotes the entity of the anonymous object created to reflect
+ -- the changes in values. Comp is the component/index expression to be
+ -- updated. Expr is an expression yielding the new value of Comp. Typ
+ -- is the type of the prefix of attribute Update.
+
+ procedure Process_Range_Update
+ (Temp : Entity_Id;
+ Comp : Node_Id;
+ Expr : Node_Id);
+ -- Generate the statements necessary to update a slice of the prefix.
+ -- The code is inserted before the attribute N. Temp denotes the entity
+ -- of the anonymous object created to reflect the changes in values.
+ -- Comp is range of the slice to be updated. Expr is an expression
+ -- yielding the new value of Comp.
+
+ -----------------------------------------
+ -- Process_Component_Or_Element_Update --
+ -----------------------------------------
+
+ procedure Process_Component_Or_Element_Update
+ (Temp : Entity_Id;
+ Comp : Node_Id;
+ Expr : Node_Id;
+ Typ : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Comp);
+ Exprs : List_Id;
+ LHS : Node_Id;
+
+ begin
+ -- An array element may be modified by the following relations
+ -- depending on the number of dimensions:
+
+ -- 1 => Expr -- one dimensional update
+ -- (1, ..., N) => Expr -- multi dimensional update
+
+ -- The above forms are converted in assignment statements where the
+ -- left hand side is an indexed component:
+
+ -- Temp (1) := Expr; -- one dimensional update
+ -- Temp (1, ..., N) := Expr; -- multi dimensional update
+
+ if Is_Array_Type (Typ) then
+
+ -- The index expressions of a multi dimensional array update
+ -- appear as an aggregate.
+
+ if Nkind (Comp) = N_Aggregate then
+ Exprs := New_Copy_List_Tree (Expressions (Comp));
+ else
+ Exprs := New_List (Relocate_Node (Comp));
+ end if;
+
+ LHS :=
+ Make_Indexed_Component (Loc,
+ Prefix => New_Reference_To (Temp, Loc),
+ Expressions => Exprs);
+
+ -- A record component update appears in the following form:
+
+ -- Comp => Expr
+
+ -- The above relation is transformed into an assignment statement
+ -- where the left hand side is a selected component:
+
+ -- Temp.Comp := Expr;
+
+ else pragma Assert (Is_Record_Type (Typ));
+ LHS :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Temp, Loc),
+ Selector_Name => Relocate_Node (Comp));
+ end if;
+
+ Insert_Action (N,
+ Make_Assignment_Statement (Loc,
+ Name => LHS,
+ Expression => Relocate_Node (Expr)));
+ end Process_Component_Or_Element_Update;
+
+ --------------------------
+ -- Process_Range_Update --
+ --------------------------
+
+ procedure Process_Range_Update
+ (Temp : Entity_Id;
+ Comp : Node_Id;
+ Expr : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Comp);
+ Index : Entity_Id;
+
+ begin
+ -- A range update appears as
+
+ -- (Low .. High => Expr)
+
+ -- The above construct is transformed into a loop that iterates over
+ -- the given range and modifies the corresponding array values to the
+ -- value of Expr:
+
+ -- for Index in Low .. High loop
+ -- Temp (Index) := Expr;
+ -- end loop;
+
+ Index := Make_Temporary (Loc, 'I');
+
+ Insert_Action (N,
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Index,
+ Discrete_Subtype_Definition => Relocate_Node (Comp))),
+
+ Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Reference_To (Temp, Loc),
+ Expressions => New_List (New_Reference_To (Index, Loc))),
+ Expression => Relocate_Node (Expr))),
+
+ End_Label => Empty));
+ end Process_Range_Update;
+
+ -- Local variables
+
+ Aggr : constant Node_Id := First (Expressions (N));
+ Loc : constant Source_Ptr := Sloc (N);
+ Pref : constant Node_Id := Prefix (N);
+ Typ : constant Entity_Id := Etype (Pref);
+ Assoc : Node_Id;
+ Comp : Node_Id;
+ Expr : Node_Id;
+ Temp : Entity_Id;
+
+ -- Start of processing for Expand_Update_Attribute
+
+ begin
+ -- Create the anonymous object that stores the value of the prefix and
+ -- reflects subsequent changes in value. Generate:
+
+ -- Temp : <type of Pref> := Pref;
+
+ Temp := Make_Temporary (Loc, 'T');
+
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition => New_Reference_To (Typ, Loc),
+ Expression => Relocate_Node (Pref)));
+
+ -- Process the update aggregate
+
+ Assoc := First (Component_Associations (Aggr));
+ while Present (Assoc) loop
+ Comp := First (Choices (Assoc));
+ Expr := Expression (Assoc);
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Range then
+ Process_Range_Update (Temp, Comp, Expr);
+ else
+ Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ);
+ end if;
+
+ Next (Comp);
+ end loop;
+
+ Next (Assoc);
+ end loop;
+
+ -- The attribute is replaced by a reference to the anonymous object
+
+ Rewrite (N, New_Reference_To (Temp, Loc));
+ Analyze (N);
+ end Expand_Update_Attribute;
+
-------------------
-- Find_Fat_Info --
-------------------
Temps (J) := T;
Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => T,
- Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Image,
- Prefix => New_Occurrence_Of (Etype (Indx), Loc),
- Expressions => New_List (New_Copy_Tree (Val)))));
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => T,
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Image,
+ Prefix => New_Occurrence_Of (Etype (Indx), Loc),
+ Expressions => New_List (New_Copy_Tree (Val)))));
Next_Index (Indx);
Next (Val);
Make_Op_Add (Loc,
Left_Opnd => Sum,
Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Length,
- Prefix =>
- New_Occurrence_Of (Pref, Loc),
- Expressions => New_List (Make_Integer_Literal (Loc, 1))));
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Length,
+ Prefix => New_Occurrence_Of (Pref, Loc),
+ Expressions => New_List (Make_Integer_Literal (Loc, 1))));
for J in 1 .. Dims loop
Sum :=
- Make_Op_Add (Loc,
- Left_Opnd => Sum,
+ Make_Op_Add (Loc,
+ Left_Opnd => Sum,
Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Length,
- Prefix =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Length,
+ Prefix =>
New_Occurrence_Of (Temps (J), Loc),
- Expressions => New_List (Make_Integer_Literal (Loc, 1))));
+ Expressions => New_List (Make_Integer_Literal (Loc, 1))));
end loop;
Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
Append_To (Stats,
- Make_Assignment_Statement (Loc,
- Name => Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (Res, Loc),
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Res, Loc),
Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
- Expression =>
- Make_Character_Literal (Loc,
- Chars => Name_Find,
- Char_Literal_Value =>
- UI_From_Int (Character'Pos ('(')))));
+ Expression =>
+ Make_Character_Literal (Loc,
+ Chars => Name_Find,
+ Char_Literal_Value => UI_From_Int (Character'Pos ('(')))));
Append_To (Stats,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Pos, Loc),
- Expression =>
- Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (Pos, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 1))));
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Pos, Loc),
+ Expression =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Occurrence_Of (Pos, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1))));
for J in 1 .. Dims loop
Append_To (Stats,
- Make_Assignment_Statement (Loc,
- Name => Make_Slice (Loc,
- Prefix => New_Occurrence_Of (Res, Loc),
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Slice (Loc,
+ Prefix => New_Occurrence_Of (Res, Loc),
Discrete_Range =>
Make_Range (Loc,
- Low_Bound => New_Occurrence_Of (Pos, Loc),
- High_Bound => Make_Op_Subtract (Loc,
- Left_Opnd =>
- Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (Pos, Loc),
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Length,
- Prefix =>
- New_Occurrence_Of (Temps (J), Loc),
- Expressions =>
- New_List (Make_Integer_Literal (Loc, 1)))),
+ Low_Bound => New_Occurrence_Of (Pos, Loc),
+ High_Bound =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Occurrence_Of (Pos, Loc),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Length,
+ Prefix =>
+ New_Occurrence_Of (Temps (J), Loc),
+ Expressions =>
+ New_List (Make_Integer_Literal (Loc, 1)))),
Right_Opnd => Make_Integer_Literal (Loc, 1)))),
Expression => New_Occurrence_Of (Temps (J), Loc)));
if J < Dims then
Append_To (Stats,
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Pos, Loc),
+ Name => New_Occurrence_Of (Pos, Loc),
Expression =>
Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (Pos, Loc),
+ Left_Opnd => New_Occurrence_Of (Pos, Loc),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Length,
- Prefix => New_Occurrence_Of (Temps (J), Loc),
- Expressions =>
- New_List (Make_Integer_Literal (Loc, 1))))));
+ Prefix => New_Occurrence_Of (Temps (J), Loc),
+ Expressions =>
+ New_List (Make_Integer_Literal (Loc, 1))))));
Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
Append_To (Stats,
- Make_Assignment_Statement (Loc,
- Name => Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (Res, Loc),
- Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
- Expression =>
- Make_Character_Literal (Loc,
- Chars => Name_Find,
- Char_Literal_Value =>
- UI_From_Int (Character'Pos (',')))));
+ Make_Assignment_Statement (Loc,
+ Name => Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Res, Loc),
+ Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
+ Expression =>
+ Make_Character_Literal (Loc,
+ Chars => Name_Find,
+ Char_Literal_Value => UI_From_Int (Character'Pos (',')))));
Append_To (Stats,
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Pos, Loc),
+ Name => New_Occurrence_Of (Pos, Loc),
Expression =>
Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (Pos, Loc),
+ Left_Opnd => New_Occurrence_Of (Pos, Loc),
Right_Opnd => Make_Integer_Literal (Loc, 1))));
end if;
end loop;
Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
Append_To (Stats,
- Make_Assignment_Statement (Loc,
- Name => Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (Res, Loc),
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Res, Loc),
Expressions => New_List (New_Occurrence_Of (Len, Loc))),
Expression =>
Make_Character_Literal (Loc,
- Chars => Name_Find,
- Char_Literal_Value =>
- UI_From_Int (Character'Pos (')')))));
+ Chars => Name_Find,
+ Char_Literal_Value => UI_From_Int (Character'Pos (')')))));
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
end Build_Task_Array_Image;
end if;
-- For expressions that denote objects, we can use a renaming scheme.
- -- This is needed for correctness in the case of a volatile object of a
- -- non-volatile type because the Make_Reference call of the "default"
+ -- This is needed for correctness in the case of a volatile object of
+ -- a non-volatile type because the Make_Reference call of the "default"
-- approach would generate an illegal access value (an access value
-- cannot designate such an object - see Analyze_Reference). We skip
-- using this scheme if we have an object of a volatile type and we do
-- not have Name_Req set true (see comments above for Side_Effect_Free).
+ -- In Ada 2012 a qualified expression is an object, but for purposes of
+ -- removing side effects it still need to be transformed into a separate
+ -- declaration, particularly if the expression is an aggregate.
+
elsif Is_Object_Reference (Exp)
and then Nkind (Exp) /= N_Function_Call
+ and then Nkind (Exp) /= N_Qualified_Expression
and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
then
Def_Id := Make_Temporary (Loc, 'R', Exp);
-- SUBTYPE_DECLARATION ::=
-- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION
- -- {ASPECT_SPECIFICATIONS];
+ -- [ASPECT_SPECIFICATIONS];
-- The caller has checked that the initial token is SUBTYPE
Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name))
then
Set_Expressions (Name_Node, New_List);
- Scan; -- past left paren
- loop
- declare
- Expr : constant Node_Id := P_Expression_If_OK;
+ -- Attribute Update contains an array or record association
+ -- list which provides new values for various components or
+ -- elements. The list is parsed as an aggregate.
- begin
- if Token = Tok_Arrow then
- Error_Msg_SC
- ("named parameters not permitted for attributes");
- Scan; -- past junk arrow
+ if Attr_Name = Name_Update then
+ Append (P_Aggregate, Expressions (Name_Node));
- else
- Append (Expr, Expressions (Name_Node));
- exit when not Comma_Present;
- end if;
- end;
- end loop;
+ else
+ Scan; -- past left paren
+
+ loop
+ declare
+ Expr : constant Node_Id := P_Expression_If_OK;
+
+ begin
+ if Token = Tok_Arrow then
+ Error_Msg_SC
+ ("named parameters not permitted for attributes");
+ Scan; -- past junk arrow
+
+ else
+ Append (Expr, Expressions (Name_Node));
+ exit when not Comma_Present;
+ end if;
+ end;
+ end loop;
- T_Right_Paren;
+ T_Right_Paren;
+ end if;
end if;
goto Scan_Name_Extension;
Analyze_Access_Attribute;
+ ------------
+ -- Update --
+ ------------
+
+ when Attribute_Update => Update : declare
+ Comps : Elist_Id := No_Elist;
+
+ procedure Check_Component_Reference
+ (Comp : Entity_Id;
+ Typ : Entity_Id);
+ -- Comp is a record component (possibly a discriminant) and Typ is a
+ -- record type. Determine whether Comp is a legal component of Typ.
+ -- Emit an error if Comp mentions a discriminant or is not a unique
+ -- component reference in the update aggregate.
+
+ -------------------------------
+ -- Check_Component_Reference --
+ -------------------------------
+
+ procedure Check_Component_Reference
+ (Comp : Entity_Id;
+ Typ : Entity_Id)
+ is
+ Comp_Name : constant Name_Id := Chars (Comp);
+
+ function Is_Duplicate_Component return Boolean;
+ -- Determine whether component Comp already appears in list Comps
+
+ ----------------------------
+ -- Is_Duplicate_Component --
+ ----------------------------
+
+ function Is_Duplicate_Component return Boolean is
+ Comp_Elmt : Elmt_Id;
+
+ begin
+ if Present (Comps) then
+ Comp_Elmt := First_Elmt (Comps);
+ while Present (Comp_Elmt) loop
+ if Chars (Node (Comp_Elmt)) = Comp_Name then
+ return True;
+ end if;
+
+ Next_Elmt (Comp_Elmt);
+ end loop;
+ end if;
+
+ return False;
+ end Is_Duplicate_Component;
+
+ -- Local variables
+
+ Comp_Or_Discr : Entity_Id;
+
+ -- Start of processing for Check_Component_Reference
+
+ begin
+ -- Find the discriminant or component whose name corresponds to
+ -- Comp. A simple character comparison is sufficient because all
+ -- visible names within a record type are unique.
+
+ Comp_Or_Discr := First_Entity (Typ);
+ while Present (Comp_Or_Discr) loop
+ if Chars (Comp_Or_Discr) = Comp_Name then
+ exit;
+ end if;
+
+ Comp_Or_Discr := Next_Entity (Comp_Or_Discr);
+ end loop;
+
+ -- Diagnose possible erroneous references
+
+ if Present (Comp_Or_Discr) then
+ if Ekind (Comp_Or_Discr) = E_Discriminant then
+ Error_Attr
+ ("attribute % may not modify record discriminants", Comp);
+
+ else pragma Assert (Ekind (Comp_Or_Discr) = E_Component);
+ if Is_Duplicate_Component then
+ Error_Msg_NE ("component & already updated", Comp, Comp);
+
+ -- Mark this component as processed
+
+ else
+ if No (Comps) then
+ Comps := New_Elmt_List;
+ end if;
+
+ Append_Elmt (Comp, Comps);
+ end if;
+ end if;
+
+ -- The update aggregate mentions an entity that does not belong to
+ -- the record type.
+
+ else
+ Error_Msg_NE
+ ("& is not a component of aggregate subtype", Comp, Comp);
+ end if;
+ end Check_Component_Reference;
+
+ -- Local variables
+
+ Assoc : Node_Id;
+ Comp : Node_Id;
+
+ -- Start of processing for Update
+
+ begin
+ S14_Attribute;
+ Check_E1;
+
+ if not Is_Object_Reference (P) then
+ Error_Attr_P ("prefix of attribute % must denote an object");
+
+ elsif not Is_Array_Type (P_Type)
+ and then not Is_Record_Type (P_Type)
+ then
+ Error_Attr_P ("prefix of attribute % must be a record or array");
+
+ elsif Is_Immutably_Limited_Type (P_Type) then
+ Error_Attr ("prefix of attribute % cannot be limited", N);
+
+ elsif Nkind (E1) /= N_Aggregate then
+ Error_Attr ("attribute % requires component association list", N);
+ end if;
+
+ -- Inspect the update aggregate, looking at all the associations and
+ -- choices. Perform the following checks:
+
+ -- 1) Legality of "others" in all cases
+ -- 2) Component legality for records
+
+ -- The remaining checks are performed on the expanded attribute
+
+ Assoc := First (Component_Associations (E1));
+ while Present (Assoc) loop
+ Comp := First (Choices (Assoc));
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Others_Choice then
+ Error_Attr
+ ("others choice not allowed in attribute %", Comp);
+
+ elsif Is_Record_Type (P_Type) then
+ Check_Component_Reference (Comp, P_Type);
+ end if;
+
+ Next (Comp);
+ end loop;
+
+ Next (Assoc);
+ end loop;
+
+ -- The type of attribute Update is that of the prefix
+
+ Set_Etype (N, P_Type);
+ end Update;
+
---------
-- Val --
---------
Static := True;
end Unconstrained_Array;
+ -- Attribute Update is never static
+
+ ------------
+ -- Update --
+ ------------
+
+ when Attribute_Update =>
+ null;
+
---------------
-- VADS_Size --
---------------
-- Contract_Cases --
--------------------
- -- pragma Contract_Cases (POST_CASE_LIST);
+ -- pragma Contract_Cases (CONTRACT_CASE_LIST);
- -- POST_CASE_LIST ::= POST_CASE {, POST_CASE}
+ -- CONTRACT_CASE_LIST ::= CONTRACT_CASE {, CONTRACT_CASE}
- -- POST_CASE ::= CASE_GUARD => CONSEQUENCE
+ -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
-- CASE_GUARD ::= boolean_EXPRESSION | others
CTC : Node_Id;
begin
+ Check_Duplicate_Pragma (Subp);
CTC := Spec_CTC_List (Contract (Subp));
while Present (CTC) loop
if Chars (Pragma_Identifier (CTC)) = Pname then
- Error_Pragma ("pragma % already in use");
- return;
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_Sloc := Sloc (CTC);
+
+ if From_Aspect_Specification (CTC) then
+ Error_Msg_NE
+ ("aspect% for & previously given#", N, Subp);
+ else
+ Error_Msg_NE
+ ("pragma% for & duplicates pragma#", N, Subp);
+ end if;
+
+ raise Pragma_Exit;
end if;
CTC := Next_Pragma (CTC);
-- Local variables
- Case_Guard : Node_Id;
- Decl : Node_Id;
- Extra : Node_Id;
- Others_Seen : Boolean := False;
- Post_Case : Node_Id;
- Subp_Decl : Node_Id;
+ Case_Guard : Node_Id;
+ Decl : Node_Id;
+ Extra : Node_Id;
+ Others_Seen : Boolean := False;
+ Contract_Case : Node_Id;
+ Subp_Decl : Node_Id;
-- Start of processing for Contract_Cases
end if;
end loop;
- -- All post cases must appear as an aggregate
+ -- All contract cases must appear as an aggregate
if Nkind (Expression (Arg1)) /= N_Aggregate then
Error_Pragma ("wrong syntax for pragma %");
return;
end if;
- -- Verify the legality of individual post cases
+ -- Verify the legality of individual contract cases
- Post_Case := First (Component_Associations (Expression (Arg1)));
- while Present (Post_Case) loop
- if Nkind (Post_Case) /= N_Component_Association then
- Error_Pragma_Arg ("wrong syntax in post case", Post_Case);
+ Contract_Case :=
+ First (Component_Associations (Expression (Arg1)));
+ while Present (Contract_Case) loop
+ if Nkind (Contract_Case) /= N_Component_Association then
+ Error_Pragma_Arg
+ ("wrong syntax in contract case", Contract_Case);
return;
end if;
- Case_Guard := First (Choices (Post_Case));
+ Case_Guard := First (Choices (Contract_Case));
- -- Each post case must have exactly on case guard
+ -- Each contract case must have exactly on case guard
Extra := Next (Case_Guard);
if Present (Extra) then
Error_Pragma_Arg
- ("post case may have only one case guard", Extra);
+ ("contract case may have only one case guard", Extra);
return;
end if;
return;
end if;
- Next (Post_Case);
+ Next (Contract_Case);
end loop;
Chain_Contract_Cases (Subp_Decl);
Preanalyze_And_Resolve (Expression (Arg1), Any_Boolean);
- -- Transform pagma Loop_Invariant into an equivalent pragma Check.
+ -- Transform pragma Loop_Invariant into equivalent pragma Check
-- Generate:
-- pragma Check (Loop_Invaraint, Arg1);
+ -- Seems completely wrong to hijack pragma Check this way ???
+
Rewrite (N,
Make_Pragma (Loc,
Chars => Name_Check,
Name_Unconstrained_Array : constant Name_Id := N + $;
Name_Universal_Literal_String : constant Name_Id := N + $; -- GNAT
Name_Unrestricted_Access : constant Name_Id := N + $; -- GNAT
+ Name_Update : constant Name_Id := N + $; -- GNAT
Name_VADS_Size : constant Name_Id := N + $; -- GNAT
Name_Val : constant Name_Id := N + $;
Name_Valid : constant Name_Id := N + $;
Attribute_Unconstrained_Array,
Attribute_Universal_Literal_String,
Attribute_Unrestricted_Access,
+ Attribute_Update,
Attribute_VADS_Size,
Attribute_Val,
Attribute_Valid,
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
-- a real base (Nat, either zero, or in the range 2 .. 16)
-- a sign flag (Boolean), set if negative
- -- If the base is zero, then the absolute value of the Ureal is simply
- -- numerator/denominator. If the base is non-zero, then the absolute
- -- value is num / (rbase ** den).
+ -- Negative numbers are represented by the sign flag being True.
- -- Negative numbers are represented by the sign of the numerator being
- -- negative. The denominator is always positive.
+ -- If the base is zero, then the absolute value of the Ureal is simply
+ -- numerator/denominator, where denominator is positive. If the base is
+ -- non-zero, then the absolute value is numerator / (base ** denominator).
+ -- In that case, since base is positive, (base ** denominator) is also
+ -- positive, even when denominator is negative or null.
-- A normalized Ureal value has base = 0, and numerator/denominator
-- reduced to lowest terms, with zero itself being represented as 0/1.
projects / thirdparty / gcc.git / commitdiff
