2015-03-04 Robert Dewar <dewar@adacore.com>
+ * einfo.adb (Is_ARECnF_Entity): Removed.
+ (Last_Formal): Remove special handling of Is_ARECnF_Entity.
+ (Next_Formal): Remove special handling of Is_ARECnF_Entity.
+ (Next_Formal_With_Extras): Remove special handling of Is_ARECnF_Entity.
+ (Number_Entries): Minor reformatting.
+ * einfo.ads (Is_ARECnF_Entity): Removed.
+ * exp_unst.adb (Unnest_Subprogram): Remove setting of
+ Is_ARECnF_Entity.
+ (Add_Extra_Formal): Use normal Extra_Formal circuit.
+ * sprint.adb (Write_Param_Specs): Properly handle case where
+ there are no source formals, but we have at least one Extra_Formal
+ present.
+
+2015-03-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Record_Aggregate,
+ Add_Discriminant_Values): If the value is a reference to the
+ current instance of an enclosing type, use its base type to check
+ against prefix of attribute reference, because the target type
+ may be otherwise constrained.
+
+2015-03-04 Robert Dewar <dewar@adacore.com>
+
* atree.h: Add entries for Flag287-Flag309.
* einfo.adb: Add (unused) flags Flag287-Flag309.
-- Is_Static_Type Flag281
-- Has_Nested_Subprogram Flag282
-- Uplevel_Reference_Noted Flag283
- -- Is_ARECnF_Entity Flag284
+ -- (unused) Flag284
-- (unused) Flag285
-- (unused) Flag286
-- (unused) Flag287
return Flag146 (Id);
end Is_Abstract_Type;
- function Is_ARECnF_Entity (Id : E) return B is
- begin
- return Flag284 (Id);
- end Is_ARECnF_Entity;
-
function Is_Local_Anonymous_Access (Id : E) return B is
begin
pragma Assert (Is_Access_Type (Id));
Set_Flag146 (Id, V);
end Set_Is_Abstract_Type;
- procedure Set_Is_ARECnF_Entity (Id : E; V : B := True) is
- begin
- Set_Flag284 (Id, V);
- end Set_Is_ARECnF_Entity;
-
procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True) is
begin
pragma Assert (Is_Access_Type (Id));
function Last_Formal (Id : E) return E is
Formal : E;
- NForm : E;
+
begin
pragma Assert
(Is_Overloadable (Id)
Formal := First_Formal (Id);
if Present (Formal) then
- loop
- NForm := Next_Formal (Formal);
- exit when No (NForm) or else Is_ARECnF_Entity (NForm);
- Formal := NForm;
+ while Present (Next_Formal (Formal)) loop
+ Formal := Next_Formal (Formal);
end loop;
end if;
loop
Next_Entity (P);
- -- Return Empty if no next entity, or its an ARECnF entity (since
- -- the latter is the last extra formal, not to be returned here).
-
- if No (P) or else Is_ARECnF_Entity (P) then
- return Empty;
-
- -- If next entity is a formal, return it
-
- elsif Is_Formal (P) then
+ if No (P) or else Is_Formal (P) then
return P;
-
- -- Else one, unless we have an internal entity, which we skip
-
elsif not Is_Internal (P) then
return Empty;
end if;
-----------------------------
function Next_Formal_With_Extras (Id : E) return E is
- NForm : Entity_Id;
- Next : Entity_Id;
-
begin
if Present (Extra_Formal (Id)) then
return Extra_Formal (Id);
-
else
- NForm := Next_Formal (Id);
-
- if Present (NForm) then
- return NForm;
-
- -- Deal with ARECnF entity as last extra formal
-
- else
- Next := Next_Entity (Id);
-
- if Present (Next) and then Is_ARECnF_Entity (Next) then
- return Next;
- else
- return Empty;
- end if;
- end if;
+ return Next_Formal (Id);
end if;
end Next_Formal_With_Extras;
--------------------
function Number_Entries (Id : E) return Nat is
- N : Int;
- Ent : Entity_Id;
+ N : Int;
+ Ent : Entity_Id;
begin
pragma Assert (Is_Concurrent_Type (Id));
W ("In_Use", Flag8 (Id));
W ("Is_Abstract_Subprogram", Flag19 (Id));
W ("Is_Abstract_Type", Flag146 (Id));
- W ("Is_ARECnF_Entity", Flag284 (Id));
W ("Is_Access_Constant", Flag69 (Id));
W ("Is_Ada_2005_Only", Flag185 (Id));
W ("Is_Ada_2012_Only", Flag199 (Id));
-- Extra_Formal field (i.e. the Extra_Formal field of the last "real"
-- formal points to the first extra formal, and the Extra_Formal field of
-- each extra formal points to the next one, with Empty indicating the
--- end of the list of extra formals).
+-- end of the list of extra formals). Another case of Extra_Formal arises
+-- in connection with unnesting of subprograms, where the ARECnF formal
+-- that represents an activation record pointer is an extra formal.
-- Extra_Formals (Node28)
--- Applies to subprograms and subprogram types, and also in entries
+-- Applies to subprograms and subprogram types, and also to entries
-- and entry families. Returns first extra formal of the subprogram
-- or entry. Returns Empty if there are no extra formals.
-- carry the keyword aliased, and on record components that have the
-- keyword. For Ada 2012, also applies to formal parameters.
--- Is_ARECnF_Entity (Flag284)
--- Defined in all entities. Set for the ARECnF E_In_Parameter entity that
--- is generated for nested subprograms that require an activation record.
--- Logically this is an extra formal, and must be treated that way, but
--- we can't use the normal Extra_Formal mechanism since it is designed
--- to handle only cases where an extra formal is associated with one of
--- the source formals, which is not the case for ARECnF entities. Hence
--- we use this special flag to deal with this special extra formal.
-
-- Is_Atomic (Flag85)
-- Defined in all type entities, and also in constants, components and
-- variables. Set if a pragma Atomic or Shared applies to the entity.
-- In_Private_Part (Flag45)
-- Is_Ada_2005_Only (Flag185)
-- Is_Ada_2012_Only (Flag199)
- -- Is_ARECnF_Entity (Flag284)
-- Is_Bit_Packed_Array (Flag122) (base type only)
-- Is_Aliased (Flag15)
-- Is_Character_Type (Flag63)
function Is_Ada_2005_Only (Id : E) return B;
function Is_Ada_2012_Only (Id : E) return B;
function Is_Aliased (Id : E) return B;
- function Is_ARECnF_Entity (Id : E) return B;
function Is_Asynchronous (Id : E) return B;
function Is_Atomic (Id : E) return B;
function Is_Bit_Packed_Array (Id : E) return B;
procedure Set_Is_Ada_2005_Only (Id : E; V : B := True);
procedure Set_Is_Ada_2012_Only (Id : E; V : B := True);
procedure Set_Is_Aliased (Id : E; V : B := True);
- procedure Set_Is_ARECnF_Entity (Id : E; V : B := True);
procedure Set_Is_Asynchronous (Id : E; V : B := True);
procedure Set_Is_Atomic (Id : E; V : B := True);
procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True);
pragma Inline (Is_Ada_2012_Only);
pragma Inline (Is_Aggregate_Type);
pragma Inline (Is_Aliased);
- pragma Inline (Is_ARECnF_Entity);
pragma Inline (Is_Array_Type);
pragma Inline (Is_Assignable);
pragma Inline (Is_Asynchronous);
pragma Inline (Set_Is_Ada_2005_Only);
pragma Inline (Set_Is_Ada_2012_Only);
pragma Inline (Set_Is_Aliased);
- pragma Inline (Set_Is_ARECnF_Entity);
pragma Inline (Set_Is_Asynchronous);
pragma Inline (Set_Is_Atomic);
pragma Inline (Set_Is_Bit_Packed_Array);
STJ.ARECnF :=
Make_Defining_Identifier (Loc,
Chars => Name_Find_Str (AREC_String (STJ.Lev - 1) & "F"));
- Set_Is_ARECnF_Entity (STJ.ARECnF, True);
else
STJ.ARECnF := Empty;
end if;
-- and it is not obvious how we can get what we want if we
-- try to use the normal Analyze circuit.
- Extra_Formal : declare
+ Add_Extra_Formal : declare
Encl : constant SI_Type := Enclosing_Subp (J);
STJE : Subp_Entry renames Subps.Table (Encl);
-- Index and Subp_Entry for enclosing routine
-- The formal to be added. Note that n here is one less
-- than the level of the subprogram itself (STJ.Ent).
- Formb : Entity_Id;
- -- If needed, this is the formal added to the body
-
procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id);
-- S is an N_Function/Procedure_Specification node, and F
- -- is the new entity to add to this subprogramn spec.
+ -- is the new entity to add to this subprogramn spec as
+ -- the last Extra_Formal.
----------------------
-- Add_Form_To_Spec --
procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is
Sub : constant Entity_Id := Defining_Unit_Name (S);
+ Ent : Entity_Id;
begin
- if No (First_Entity (Sub)) then
- Set_First_Entity (Sub, F);
- Set_Last_Entity (Sub, F);
+ -- Case of at least one Extra_Formal is present, set
+ -- ARECnF as the new last entry in the list.
+
+ if Present (Extra_Formals (Sub)) then
+ Ent := Extra_Formals (Sub);
+ while Present (Extra_Formal (Ent)) loop
+ Ent := Extra_Formal (Ent);
+ end loop;
+
+ Set_Extra_Formal (Ent, F);
+
+ -- No Extra formals present
else
- declare
- LastF : constant Entity_Id := Last_Formal (Sub);
- begin
- if No (LastF) then
- Set_Next_Entity (F, First_Entity (Sub));
- Set_First_Entity (Sub, F);
-
- else
- Set_Next_Entity (F, Next_Entity (LastF));
- Set_Next_Entity (LastF, F);
-
- if Last_Entity (Sub) = LastF then
- Set_Last_Entity (Sub, F);
- end if;
- end if;
- end;
- end if;
+ Set_Extra_Formals (Sub, F);
+ Ent := Last_Formal (Sub);
- if No (Parameter_Specifications (S)) then
- Set_Parameter_Specifications (S, Empty_List);
+ if Present (Ent) then
+ Set_Extra_Formal (Ent, F);
+ end if;
end if;
-
- Append_To (Parameter_Specifications (S),
- Make_Parameter_Specification (Sloc (F),
- Defining_Identifier => F,
- Parameter_Type =>
- New_Occurrence_Of (STJE.ARECnPT, Sloc (F))));
end Add_Form_To_Spec;
- -- Start of processing for Extra_Formal
+ -- Start of processing for Add_Extra_Formal
begin
-- Decorate the new formal entity
-- Case of separate spec
else
- Formb := New_Entity (Nkind (Form), Sloc (Form));
- Copy_Node (Form, Formb);
Add_Form_To_Spec (Form, Parent (STJ.Ent));
- Add_Form_To_Spec (Formb, Specification (STJ.Bod));
end if;
- end Extra_Formal;
+ end Add_Extra_Formal;
end if;
-- Processing for subprograms that have at least one nested
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
Aggr_Range : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
-- Constrained N_Range of each index dimension in our aggregate itype
- Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
- Aggr_High : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
+ Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
+ Aggr_High : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
-- Low and High bounds for each index dimension in our aggregate itype
Is_Fully_Positional : Boolean := True;
-- regardless of the staticness of the bounds themselves. Subsequent
-- checks in exp_aggr verify that type is not packed, etc.
- Set_Size_Known_At_Compile_Time (Itype,
+ Set_Size_Known_At_Compile_Time
+ (Itype,
Is_Fully_Positional
and then Comes_From_Source (N)
and then Size_Known_At_Compile_Time (Component_Type (Typ)));
Ind := First_Index (Etype (Comp));
while Present (Ind) loop
if Nkind (Ind) /= N_Range
- or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal
+ or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal
or else Nkind (High_Bound (Ind)) /= N_Integer_Literal
then
return;
begin
return No (Expressions (Aggr))
and then
- Nkind (First (Choices (First (Component_Associations (Aggr)))))
- = N_Others_Choice;
+ Nkind (First (Choices (First (Component_Associations (Aggr))))) =
+ N_Others_Choice;
end Is_Others_Aggregate;
----------------------------
Expr_Pos :=
Make_Op_Add (Loc,
- Left_Opnd => To_Pos,
- Right_Opnd => Make_Integer_Literal (Loc, Val));
+ Left_Opnd => To_Pos,
+ Right_Opnd => Make_Integer_Literal (Loc, Val));
Expr :=
Make_Attribute_Reference
and then Compile_Time_Known_Value (First (Expressions (From)))
then
Value := Expr_Value (First (Expressions (From)));
-
else
Value := Uint_0;
OK := False;
if Paren_Count (Expr) > 0 then
Error_Msg_N
- ("\if single-component aggregate is intended,"
- & " write e.g. (1 ='> ...)", Expr);
+ ("\if single-component aggregate is intended, "
+ & "write e.g. (1 ='> ...)", Expr);
end if;
return Failure;
-- Variables local to Resolve_Array_Aggregate
- Assoc : Node_Id;
- Choice : Node_Id;
- Expr : Node_Id;
-
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Expr : Node_Id;
Discard : Node_Id;
- pragma Warnings (Off, Discard);
Delete_Choice : Boolean;
-- Used when replacing a subtype choice with predicate by a list
while Present (Assoc) loop
Choice := First (Choices (Assoc));
Delete_Choice := False;
-
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Others_Present := True;
if Has_Dynamic_Predicate_Aspect
(Entity (Subtype_Mark (Choice)))
then
- Error_Msg_NE ("subtype& has dynamic predicate, "
- & "not allowed in aggregate choice",
- Choice, Entity (Subtype_Mark (Choice)));
+ Error_Msg_NE
+ ("subtype& has dynamic predicate, "
+ & "not allowed in aggregate choice",
+ Choice, Entity (Subtype_Mark (Choice)));
end if;
-- Does the subtype indication evaluation raise CE?
and then Nb_Choices /= 1
then
Error_Msg_N
- ("dynamic or empty choice in aggregate " &
- "must be the only choice", Choice);
+ ("dynamic or empty choice in aggregate "
+ & "must be the only choice", Choice);
return Failure;
end if;
-- any of the bounds have values that are not known at
-- compile time.
- -- Another case warranting a warning is when the length is
- -- right, but as above we have an index type that is an
- -- enumeration, and the bounds do not match. This is a
- -- case where dubious sliding is allowed and we generate
- -- a warning that the bounds do not match.
+ -- Another case warranting a warning is when the length
+ -- is right, but as above we have an index type that is
+ -- an enumeration, and the bounds do not match. This is a
+ -- case where dubious sliding is allowed and we generate a
+ -- warning that the bounds do not match.
if No (Expressions (N))
and then Nkind (Index) = N_Range
-- Ada 2005 (AI-231)
- if Ada_Version >= Ada_2005
- and then Known_Null (Expr)
- then
+ if Ada_Version >= Ada_2005 and then Known_Null (Expr) then
Check_Can_Never_Be_Null (Etype (N), Expr);
end if;
-- Ada 2005 (AI-231)
- if Ada_Version >= Ada_2005
- and then Known_Null (Assoc)
- then
+ if Ada_Version >= Ada_2005 and then Known_Null (Assoc) then
Check_Can_Never_Be_Null (Etype (N), Expression (Assoc));
end if;
if Is_Tagged_Type (Etype (Expr)) then
Check_Dynamically_Tagged_Expression
- (Expr => Expr,
- Typ => Component_Type (Etype (N)),
+ (Expr => Expr,
+ Typ => Component_Type (Etype (N)),
Related_Nod => N);
end if;
end;
-- In SPARK, the ancestor part cannot be a type mark
- if Is_Entity_Name (A)
- and then Is_Type (Entity (A))
- then
+ if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
Check_SPARK_05_Restriction ("ancestor part cannot be a type mark", A);
-- AI05-0115: if the ancestor part is a subtype mark, the ancestor
return;
end if;
- if Is_Entity_Name (A)
- and then Is_Type (Entity (A))
- then
+ if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
A_Type := Get_Full_View (Entity (A));
if Valid_Ancestor_Type then
Get_First_Interp (A, I, It);
while Present (It.Typ) loop
+
-- Only consider limited interpretations in the Ada 2005 case
if Is_Tagged_Type (It.Typ)
if A_Type = Any_Type then
if Ada_Version >= Ada_2005 then
- Error_Msg_N ("ancestor part must be of a tagged type", A);
+ Error_Msg_N
+ ("ancestor part must be of a tagged type", A);
else
Error_Msg_N
("ancestor part must be of a nonlimited tagged type", A);
begin
Is_Box_Present := False;
- if Present (From) then
- Assoc := First (From);
- else
+ if No (From) then
return Empty;
end if;
+ Assoc := First (From);
while Present (Assoc) loop
Selector_Name := First (Choices (Assoc));
while Present (Selector_Name) loop
if Is_Generic_Type (Base_Type (Typ)) then
Error_Msg_NE
- ("\instance should provide actual "
- & "type with initialization for&",
- Assoc, Typ);
+ ("\instance should provide actual type with "
+ & "initialization for&", Assoc, Typ);
end if;
end if;
is
New_Copy : constant Node_Id :=
New_Copy_Tree (Source, Map, New_Sloc, New_Scope);
+
begin
-- Move the dimensions of Source to New_Copy
then
Error_Msg_NE
("aggregate not available for type& whose ancestor "
- & "has unknown discriminants ", N, Typ);
+ & "has unknown discriminants ", N, Typ);
end if;
if Has_Unknown_Discriminants (Typ)
if not Discr_Present (Discrim) then
if Present (Expr) then
Error_Msg_NE
- ("more than one value supplied for discriminant&",
+ ("more than one value supplied for discriminant &",
N, Discrim);
end if;
if Has_Discriminants (Typ)
or else (Has_Unknown_Discriminants (Typ)
- and then Present (Underlying_Record_View (Typ)))
+ and then Present (Underlying_Record_View (Typ)))
then
Build_Constrained_Itype : declare
Loc : constant Source_Ptr := Sloc (N);
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Underlying_Record_View (Typ), Loc),
- Constraint =>
+ Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, C));
else
Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Base_Type (Typ), Loc),
- Constraint =>
+ Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, C));
end if;
function Find_Private_Ancestor return Entity_Id is
Par : Entity_Id;
+
begin
Par := Typ;
loop
Cunit_Entity
(Get_Source_Unit (Base_Type (Etype (Ancestor))));
begin
-
- -- check whether we are in a scope that has full view
+ -- Check whether we are in a scope that has full view
-- over the private ancestor and its parent. This can
-- only happen if the derivation takes place in a child
-- unit of the unit that declares the parent, and we are
and then In_Open_Scopes (Scope (Ancestor))
and then
(In_Private_Part (Scope (Ancestor))
- or else In_Package_Body (Scope (Ancestor)))
+ or else In_Package_Body (Scope (Ancestor)))
then
null;
else
Error_Msg_NE
("type of aggregate has private ancestor&!",
- N, Root_Typ);
+ N, Root_Typ);
Error_Msg_N ("must use extension aggregate!", N);
return;
end if;
-- Ada 2005 (AI-231)
- if Ada_Version >= Ada_2005
- and then Known_Null (Positional_Expr)
- then
+ if Ada_Version >= Ada_2005 and then Known_Null (Positional_Expr) then
Check_Can_Never_Be_Null (Component, Positional_Expr);
end if;
Assoc := First (Assoc_List);
while Present (Assoc) loop
if Present
- (Entity (First (Choices (Assoc))))
+ (Entity (First (Choices (Assoc))))
and then
- Entity (First (Choices (Assoc)))
- = Val
+ Entity (First (Choices (Assoc))) = Val
then
Discr_Val := Expression (Assoc);
exit;
end if;
+
Next (Assoc);
end loop;
end if;
Add_Association
(Discr, New_Copy_Tree (Discr_Val),
- Component_Associations (New_Aggr));
+ Component_Associations (New_Aggr));
-- If the discriminant constraint is a current
-- instance, mark the current aggregate so that
-- the self-reference can be expanded later.
+ -- The constraint may refer to the subtype of
+ -- aggregate, so use base type for comparison.
if Nkind (Discr_Val) = N_Attribute_Reference
and then Is_Entity_Name (Prefix (Discr_Val))
and then Is_Type (Entity (Prefix (Discr_Val)))
- and then Etype (N) =
- Entity (Prefix (Discr_Val))
+ and then Base_Type (Etype (N)) =
+ Entity (Prefix (Discr_Val))
then
Set_Has_Self_Reference (N);
end if;
end loop;
end Add_Discriminant_Values;
- ------------------------------
- -- Propagate_Discriminants --
- ------------------------------
+ -----------------------------
+ -- Propagate_Discriminants --
+ -----------------------------
procedure Propagate_Discriminants
(Aggr : Node_Id;
-- inner aggregate, and recurse if component is
-- itself composite.
- ------------------------
- -- Process_Component --
- ------------------------
+ -----------------------
+ -- Process_Component --
+ -----------------------
procedure Process_Component (Comp : Entity_Id) is
- T : constant Entity_Id := Etype (Comp);
- New_Aggr : Node_Id;
+ T : constant Entity_Id := Etype (Comp);
+ New_Aggr : Node_Id;
begin
if Is_Record_Type (T)
-- list of the current aggregate.
if Nkind (Def_Node) = N_Record_Definition
- and then
- Present (Component_List (Def_Node))
+ and then Present (Component_List (Def_Node))
and then
Present
(Variant_Part (Component_List (Def_Node)))
Comp_Elmt := First_Elmt (Components);
while Present (Comp_Elmt) loop
- if
- Ekind (Node (Comp_Elmt)) /= E_Discriminant
+ if Ekind (Node (Comp_Elmt)) /= E_Discriminant
then
Process_Component (Node (Comp_Elmt));
end if;
(Component_Associations (Expr),
Make_Component_Association (Loc,
Choices =>
- New_List
- (Make_Others_Choice (Loc)),
+ New_List (
+ Make_Others_Choice (Loc)),
Expression => Empty,
- Box_Present => True));
+ Box_Present => True));
end if;
exit;
end if;
-- Ada 2005 (AI-287): others choice may have expression or box
- if No (Others_Etype)
- and then not Others_Box
- then
+ if No (Others_Etype) and then not Others_Box then
Error_Msg_N
("OTHERS must represent at least one component", Selectr);
end if;
-- characters {} if the Do_Overflow flag is set on the node N.
procedure Write_Param_Specs (N : Node_Id);
- -- Output parameter specifications for node (which is either a function
- -- or procedure specification with a Parameter_Specifications field)
+ -- Output parameter specifications for node N (which is a subprogram, or
+ -- entry or entry family or access-subprogram-definition, all of which
+ -- have a Parameter_Specificatioons field).
procedure Write_Rewrite_Str (S : String);
-- Writes out a string (typically containing <<< or >>>}) for a node
-----------------------
procedure Write_Param_Specs (N : Node_Id) is
- Specs : List_Id;
+ Specs : constant List_Id := Parameter_Specifications (N);
+ Specs_Present : constant Boolean := Is_Non_Empty_List (Specs);
+
+ Ent : Entity_Id;
+ Extras : Node_Id;
Spec : Node_Id;
Formal : Node_Id;
+ Output : Boolean := False;
+ -- Set true if we output at least one parameter
+
begin
- Specs := Parameter_Specifications (N);
+ -- Write out explicit specs from Parameter_Speficiations list
- if Is_Non_Empty_List (Specs) then
+ if Specs_Present then
Write_Str_With_Col_Check (" (");
- Spec := First (Specs);
+ Output := True;
+ Spec := First (Specs);
loop
Sprint_Node (Spec);
Formal := Defining_Identifier (Spec);
Write_Str ("; ");
end if;
end loop;
+ end if;
- -- Write out any extra formals
+ -- See if we have extra formals
- while Present (Extra_Formal (Formal)) loop
- Formal := Extra_Formal (Formal);
- Write_Str ("; ");
- Write_Name_With_Col_Check (Chars (Formal));
- Write_Str (" : ");
- Write_Name_With_Col_Check (Chars (Etype (Formal)));
- end loop;
+ if Nkind_In (N, N_Function_Specification,
+ N_Procedure_Specification)
+ then
+ Ent := Defining_Entity (N);
+
+ -- Loop to write extra formals (if any)
+
+ if Present (Ent) and then Is_Subprogram (Ent) then
+ Extras := Extra_Formals (Ent);
+
+ if Present (Extras) then
+ if not Specs_Present then
+ Write_Str_With_Col_Check (" (");
+ Output := True;
+ end if;
+
+ Formal := Extras;
+ while Present (Formal) loop
+ if Specs_Present or else Formal /= Extras then
+ Write_Str ("; ");
+ end if;
+
+ Write_Name_With_Col_Check (Chars (Formal));
+ Write_Str (" : ");
+ Write_Name_With_Col_Check (Chars (Etype (Formal)));
+ Formal := Extra_Formal (Formal);
+ end loop;
+ end if;
+ end if;
+ end if;
+ if Output then
Write_Char (')');
end if;
end Write_Param_Specs;
projects / platform / upstream / gcc.git / commitdiff