-- Local Subprograms and Variables --
-------------------------------------
+ procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id);
+ -- Subsidiary routine to the analysis of pragmas Depends and Global. Append
+ -- an input or output item to a list. If the list is empty, a new one is
+ -- created.
+
function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
-- This routine is used for possible casing adjustment of an explicit
-- external name supplied as a string literal (the node N), according to
-- pragma. Entity name for unit and its parents is taken from item in
-- previous with_clause that mentions the unit.
+ --------------
+ -- Add_Item --
+ --------------
+
+ procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is
+ begin
+ if No (To_List) then
+ To_List := New_Elmt_List;
+ end if;
+
+ Append_Unique_Elmt (Item, To_List);
+ end Add_Item;
+
-------------------------------
-- Adjust_External_Name_Case --
-------------------------------
End_Scope;
end Analyze_CTC_In_Decl_Part;
- ------------------------------
- -- Analyze_PPC_In_Decl_Part --
- ------------------------------
+ ----------------------------------
+ -- Analyze_Depends_In_Decl_Part --
+ ----------------------------------
+
+ procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
+ Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
+ Loc : constant Source_Ptr := Sloc (N);
+
+ All_Inputs_Seen : Elist_Id := No_Elist;
+ -- A list containing the entities of all the inputs processed so far.
+ -- This Elist is populated with unique entities because the same input
+ -- may appear in multiple input lists.
+
+ Global_Seen : Boolean := False;
+ -- A flag set when pragma Global has been processed
+
+ Outputs_Seen : Elist_Id := No_Elist;
+ -- A list containing the entities of all the outputs processed so far.
+ -- The elements of this list may come from different output lists.
+
+ Null_Output_Seen : Boolean := False;
+ -- A flag used to track the legality of a null output
+
+ Result_Seen : Boolean := False;
+ -- A flag set when Subp_Id'Result is processed
+
+ Subp_Id : Entity_Id;
+ -- The entity of the subprogram subject to pragma Depends
+
+ Subp_Inputs : Elist_Id := No_Elist;
+ Subp_Outputs : Elist_Id := No_Elist;
+ -- Two lists containing the full set of inputs and output of the related
+ -- subprograms. Note that these lists contain both nodes and entities.
+
+ procedure Analyze_Dependency_Clause
+ (Clause : Node_Id;
+ Is_Last : Boolean);
+ -- Verify the legality of a single dependency clause. Flag Is_Last
+ -- denotes whether Clause is the last clause in the relation.
+
+ function Appears_In
+ (List : Elist_Id;
+ Item_Id : Entity_Id) return Boolean;
+ -- Determine whether a particular item appears in a mixed list of nodes
+ -- and entities.
+
+ procedure Check_Function_Return;
+ -- Verify that Funtion'Result appears as one of the outputs
+
+ procedure Check_Mode
+ (Item : Node_Id;
+ Item_Id : Entity_Id;
+ Is_Input : Boolean;
+ Self_Ref : Boolean);
+ -- Ensure that an item has a proper "in", "in out" or "out" mode
+ -- depending on its function. If this is not the case, emit an error.
+ -- Item and Item_Id denote the attributes of an item. Flag Is_Input
+ -- should be set when item comes from an input list. Flag Self_Ref
+ -- should be set when the item is an output and the dependency clause
+ -- has operator "+".
+
+ procedure Check_Usage
+ (Subp_Items : Elist_Id;
+ Used_Items : Elist_Id;
+ Is_Input : Boolean);
+ -- Verify that all items from Subp_Items appear in Used_Items. Emit an
+ -- error if this is not the case.
+
+ procedure Collect_Subprogram_Inputs_Outputs;
+ -- Gather all inputs and outputs of the subprogram. These are the formal
+ -- parameters and entities classified in pragma Global.
+
+ procedure Normalize_Clause (Clause : Node_Id);
+ -- Remove a self-dependency "+" from the input list of a clause.
+ -- Depending on the contents of the relation, either split the the
+ -- clause into multiple smaller clauses or perform the normalization in
+ -- place.
- procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
- Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
+ -------------------------------
+ -- Analyze_Dependency_Clause --
+ -------------------------------
- begin
- -- Install formals and push subprogram spec onto scope stack so that we
- -- can see the formals from the pragma.
+ procedure Analyze_Dependency_Clause
+ (Clause : Node_Id;
+ Is_Last : Boolean)
+ is
+ procedure Analyze_Input_List (Inputs : Node_Id);
+ -- Verify the legality of a single input list
+
+ procedure Analyze_Input_Output
+ (Item : Node_Id;
+ Is_Input : Boolean;
+ Self_Ref : Boolean;
+ Top_Level : Boolean;
+ Seen : in out Elist_Id;
+ Null_Seen : in out Boolean);
+ -- Verify the legality of a single input or output item. Flag
+ -- Is_Input should be set whenever Item is an input, False when it
+ -- denotes an output. Flag Self_Ref should be set when the item is an
+ -- output and the dependency clause has a "+". Flag Top_Level should
+ -- be set whenever Item appears immediately within an input or output
+ -- list. Seen is a collection of all abstract states, variables and
+ -- formals processed so far. Flag Null_Seen denotes whether a null
+ -- input or output has been encountered.
- Install_Formals (S);
- Push_Scope (S);
+ ------------------------
+ -- Analyze_Input_List --
+ ------------------------
- -- Preanalyze the boolean expression, we treat this as a spec expression
- -- (i.e. similar to a default expression).
+ procedure Analyze_Input_List (Inputs : Node_Id) is
+ Inputs_Seen : Elist_Id := No_Elist;
+ -- A list containing the entities of all inputs that appear in the
+ -- current input list.
- Preanalyze_Assert_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean);
+ Null_Input_Seen : Boolean := False;
+ -- A flag used to track the legality of a null input
- -- In ASIS mode, for a pragma generated from a source aspect, also
- -- analyze the original aspect expression.
+ Input : Node_Id;
- if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
- Preanalyze_Assert_Expression
- (Expression (Corresponding_Aspect (N)), Standard_Boolean);
- end if;
+ begin
+ -- Multiple inputs appear as an aggregate
- -- For a class-wide condition, a reference to a controlling formal must
- -- be interpreted as having the class-wide type (or an access to such)
- -- so that the inherited condition can be properly applied to any
- -- overriding operation (see ARM12 6.6.1 (7)).
+ if Nkind (Inputs) = N_Aggregate then
+ if Present (Component_Associations (Inputs)) then
+ Error_Msg_N
+ ("nested dependency relations not allowed", Inputs);
- if Class_Present (N) then
- Class_Wide_Condition : declare
- T : constant Entity_Id := Find_Dispatching_Type (S);
+ elsif Present (Expressions (Inputs)) then
+ Input := First (Expressions (Inputs));
+ while Present (Input) loop
+ Analyze_Input_Output
+ (Item => Input,
+ Is_Input => True,
+ Self_Ref => False,
+ Top_Level => False,
+ Seen => Inputs_Seen,
+ Null_Seen => Null_Input_Seen);
- ACW : Entity_Id := Empty;
- -- Access to T'class, created if there is a controlling formal
- -- that is an access parameter.
+ Next (Input);
+ end loop;
- function Get_ACW return Entity_Id;
- -- If the expression has a reference to an controlling access
- -- parameter, create an access to T'class for the necessary
- -- conversions if one does not exist.
+ else
+ Error_Msg_N ("malformed input dependency list", Inputs);
+ end if;
- function Process (N : Node_Id) return Traverse_Result;
- -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
- -- aspect for a primitive subprogram of a tagged type T, a name
- -- that denotes a formal parameter of type T is interpreted as
- -- having type T'Class. Similarly, a name that denotes a formal
- -- accessparameter of type access-to-T is interpreted as having
- -- type access-to-T'Class. This ensures the expression is well-
- -- defined for a primitive subprogram of a type descended from T.
+ -- Process a solitary input
- -------------
- -- Get_ACW --
- -------------
+ else
+ Analyze_Input_Output
+ (Item => Inputs,
+ Is_Input => True,
+ Self_Ref => False,
+ Top_Level => False,
+ Seen => Inputs_Seen,
+ Null_Seen => Null_Input_Seen);
+ end if;
- function Get_ACW return Entity_Id is
- Loc : constant Source_Ptr := Sloc (N);
- Decl : Node_Id;
+ -- Detect an illegal dependency clause of the form
- begin
- if No (ACW) then
- Decl := Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'T'),
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (Class_Wide_Type (T), Loc),
- All_Present => True));
+ -- (null =>[+] null)
- Insert_Before (Unit_Declaration_Node (S), Decl);
- Analyze (Decl);
- ACW := Defining_Identifier (Decl);
- Freeze_Before (Unit_Declaration_Node (S), ACW);
+ if Null_Output_Seen and then Null_Input_Seen then
+ Error_Msg_N
+ ("null dependency clause cannot have a null input list",
+ Inputs);
+ end if;
+ end Analyze_Input_List;
+
+ --------------------------
+ -- Analyze_Input_Output --
+ --------------------------
+
+ procedure Analyze_Input_Output
+ (Item : Node_Id;
+ Is_Input : Boolean;
+ Self_Ref : Boolean;
+ Top_Level : Boolean;
+ Seen : in out Elist_Id;
+ Null_Seen : in out Boolean)
+ is
+ Is_Output : constant Boolean := not Is_Input;
+ Grouped : Node_Id;
+ Item_Id : Entity_Id;
+
+ begin
+ -- Multiple input or output items appear as an aggregate
+
+ if Nkind (Item) = N_Aggregate then
+ if not Top_Level then
+ Error_Msg_N ("nested grouping of items not allowed", Item);
+
+ elsif Present (Component_Associations (Item)) then
+ Error_Msg_N
+ ("nested dependency relations not allowed", Item);
+
+ -- Recursively analyze the grouped items
+
+ elsif Present (Expressions (Item)) then
+ Grouped := First (Expressions (Item));
+ while Present (Grouped) loop
+ Analyze_Input_Output
+ (Item => Grouped,
+ Is_Input => Is_Input,
+ Self_Ref => Self_Ref,
+ Top_Level => False,
+ Seen => Seen,
+ Null_Seen => Null_Seen);
+
+ Next (Grouped);
+ end loop;
+
+ else
+ Error_Msg_N ("malformed dependency list", Item);
end if;
- return ACW;
- end Get_ACW;
+ -- Process Function'Result in the context of a dependency clause
- -------------
- -- Process --
- -------------
+ elsif Nkind (Item) = N_Attribute_Reference
+ and then Attribute_Name (Item) = Name_Result
+ then
+ -- It is sufficent to analyze the prefix of 'Result in order to
+ -- establish legality of the attribute.
- function Process (N : Node_Id) return Traverse_Result is
- Loc : constant Source_Ptr := Sloc (N);
- Typ : Entity_Id;
+ Analyze (Prefix (Item));
- begin
- if Is_Entity_Name (N)
- and then Is_Formal (Entity (N))
- and then Nkind (Parent (N)) /= N_Type_Conversion
+ -- The prefix of 'Result must denote the function for which
+ -- aspect/pragma Depends applies.
+
+ if not Is_Entity_Name (Prefix (Item))
+ or else Ekind (Subp_Id) /= E_Function
+ or else Entity (Prefix (Item)) /= Subp_Id
then
- if Etype (Entity (N)) = T then
- Typ := Class_Wide_Type (T);
+ Error_Msg_Name_1 := Name_Result;
+ Error_Msg_N
+ ("prefix of attribute % must denote the enclosing "
+ & "function", Item);
- elsif Is_Access_Type (Etype (Entity (N)))
- and then Designated_Type (Etype (Entity (N))) = T
- then
- Typ := Get_ACW;
- else
- Typ := Empty;
- end if;
+ -- Function'Result is allowed to appear on the output side of a
+ -- dependency clause.
- if Present (Typ) then
- Rewrite (N,
- Make_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Typ, Loc),
- Expression => New_Occurrence_Of (Entity (N), Loc)));
- Set_Etype (N, Typ);
+ elsif Is_Input then
+ Error_Msg_N ("function result cannot act as input", Item);
+
+ else
+ Result_Seen := True;
+ end if;
+
+ -- Detect multiple uses of null in a single dependency list or
+ -- throughout the whole relation. Verify the placement of a null
+ -- output list relative to the other clauses.
+
+ elsif Nkind (Item) = N_Null then
+ if Null_Seen then
+ Error_Msg_N
+ ("multiple null dependency relations not allowed", Item);
+ else
+ Null_Seen := True;
+
+ if Is_Output and then not Is_Last then
+ Error_Msg_N
+ ("null output list must be the last clause in a "
+ & "dependency relation", Item);
end if;
end if;
- return OK;
- end Process;
+ -- Default case
- procedure Replace_Type is new Traverse_Proc (Process);
+ else
+ Analyze (Item);
- -- Start of processing for Class_Wide_Condition
+ -- Find the entity of the item. If this is a renaming, climb
+ -- the renaming chain to reach the root object. Renamings of
+ -- non-entire objects do not yield an entity (Empty).
- begin
- if not Present (T) then
- Error_Msg_Name_1 :=
- Chars (Identifier (Corresponding_Aspect (N)));
+ Item_Id := Entity_Of (Item);
- Error_Msg_Name_2 := Name_Class;
+ if Present (Item_Id) then
+ if Ekind_In (Item_Id, E_Abstract_State,
+ E_In_Parameter,
+ E_In_Out_Parameter,
+ E_Out_Parameter,
+ E_Variable)
+ then
+ -- Ensure that the item is of the correct mode depending
+ -- on its function.
- Error_Msg_N
- ("aspect `%''%` can only be specified for a primitive "
- & "operation of a tagged type", Corresponding_Aspect (N));
- end if;
+ Check_Mode (Item, Item_Id, Is_Input, Self_Ref);
- Replace_Type (Get_Pragma_Arg (Arg1));
- end Class_Wide_Condition;
- end if;
+ -- Detect multiple uses of the same state, variable or
+ -- formal parameter. If this is not the case, add the
+ -- item to the list of processed relations.
- -- Remove the subprogram from the scope stack now that the pre-analysis
- -- of the precondition/postcondition is done.
+ if Contains (Seen, Item_Id) then
+ Error_Msg_N ("duplicate use of item", Item);
+ else
+ Add_Item (Item_Id, Seen);
+ end if;
- End_Scope;
- end Analyze_PPC_In_Decl_Part;
+ -- Detect an illegal use of an input related to a null
+ -- output. Such input items cannot appear in other input
+ -- lists.
- --------------------
- -- Analyze_Pragma --
- --------------------
+ if Null_Output_Seen
+ and then Contains (All_Inputs_Seen, Item_Id)
+ then
+ Error_Msg_N
+ ("input of a null output list appears in multiple "
+ & "input lists", Item);
+ else
+ Add_Item (Item_Id, All_Inputs_Seen);
+ end if;
- procedure Analyze_Pragma (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Prag_Id : Pragma_Id;
+ -- When the item renames an entire object, replace the
+ -- item with a reference to the object.
- Pname : Name_Id;
- -- Name of the source pragma, or name of the corresponding aspect for
- -- pragmas which originate in a source aspect. In the latter case, the
- -- name may be different from the pragma name.
+ if Present (Renamed_Object (Entity (Item))) then
+ Rewrite (Item,
+ New_Reference_To (Item_Id, Sloc (Item)));
+ Analyze (Item);
+ end if;
- Pragma_Exit : exception;
- -- This exception is used to exit pragma processing completely. It is
- -- used when an error is detected, and no further processing is
- -- required. It is also used if an earlier error has left the tree in
- -- a state where the pragma should not be processed.
+ -- All other input/output items are illegal
- Arg_Count : Nat;
- -- Number of pragma argument associations
+ else
+ Error_Msg_N
+ ("item must denote variable, state or formal "
+ & "parameter", Item);
+ end if;
- Arg1 : Node_Id;
- Arg2 : Node_Id;
- Arg3 : Node_Id;
- Arg4 : Node_Id;
- -- First four pragma arguments (pragma argument association nodes, or
- -- Empty if the corresponding argument does not exist).
+ -- All other input/output items are illegal
- type Name_List is array (Natural range <>) of Name_Id;
- type Args_List is array (Natural range <>) of Node_Id;
- -- Types used for arguments to Check_Arg_Order and Gather_Associations
+ else
+ Error_Msg_N
+ ("item must denote variable, state or formal parameter",
+ Item);
+ end if;
+ end if;
+ end Analyze_Input_Output;
- procedure Ada_2005_Pragma;
- -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
- -- Ada 95 mode, these are implementation defined pragmas, so should be
- -- caught by the No_Implementation_Pragmas restriction.
+ -- Local variables
- procedure Ada_2012_Pragma;
- -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
- -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
- -- should be caught by the No_Implementation_Pragmas restriction.
+ Inputs : Node_Id;
+ Output : Node_Id;
+ Self_Ref : Boolean;
- procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id);
- -- Subsidiary routine to the analysis of pragmas Depends and Global.
- -- Append an input or output item to a list. If the list is empty, a
- -- new one is created.
+ -- Start of processing for Analyze_Dependency_Clause
- procedure Check_Ada_83_Warning;
- -- Issues a warning message for the current pragma if operating in Ada
- -- 83 mode (used for language pragmas that are not a standard part of
- -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
- -- of 95 pragma.
+ begin
+ Inputs := Expression (Clause);
+ Self_Ref := False;
- procedure Check_Arg_Count (Required : Nat);
- -- Check argument count for pragma is equal to given parameter. If not,
- -- then issue an error message and raise Pragma_Exit.
+ -- An input list with a self-dependency appears as operator "+" where
+ -- the actuals inputs are the right operand.
- -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
- -- Arg which can either be a pragma argument association, in which case
- -- the check is applied to the expression of the association or an
- -- expression directly.
+ if Nkind (Inputs) = N_Op_Plus then
+ Inputs := Right_Opnd (Inputs);
+ Self_Ref := True;
+ end if;
- procedure Check_Arg_Is_External_Name (Arg : Node_Id);
- -- Check that an argument has the right form for an EXTERNAL_NAME
- -- parameter of an extended import/export pragma. The rule is that the
- -- name must be an identifier or string literal (in Ada 83 mode) or a
- -- static string expression (in Ada 95 mode).
+ -- Process the output_list of a dependency_clause
- procedure Check_Arg_Is_Identifier (Arg : Node_Id);
- -- Check the specified argument Arg to make sure that it is an
- -- identifier. If not give error and raise Pragma_Exit.
+ Output := First (Choices (Clause));
+ while Present (Output) loop
+ Analyze_Input_Output
+ (Item => Output,
+ Is_Input => False,
+ Self_Ref => Self_Ref,
+ Top_Level => True,
+ Seen => Outputs_Seen,
+ Null_Seen => Null_Output_Seen);
- procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
- -- Check the specified argument Arg to make sure that it is an integer
- -- literal. If not give error and raise Pragma_Exit.
+ Next (Output);
+ end loop;
- procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
- -- Check the specified argument Arg to make sure that it has the proper
- -- syntactic form for a local name and meets the semantic requirements
- -- for a local name. The local name is analyzed as part of the
- -- processing for this call. In addition, the local name is required
- -- to represent an entity at the library level.
+ -- Process the input_list of a dependency_clause
- procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
- -- Check the specified argument Arg to make sure that it has the proper
- -- syntactic form for a local name and meets the semantic requirements
- -- for a local name. The local name is analyzed as part of the
- -- processing for this call.
+ Analyze_Input_List (Inputs);
+ end Analyze_Dependency_Clause;
- procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
- -- Check the specified argument Arg to make sure that it is a valid
- -- locking policy name. If not give error and raise Pragma_Exit.
+ ----------------
+ -- Appears_In --
+ ----------------
- procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
- -- Check the specified argument Arg to make sure that it is a valid
- -- elaboration policy name. If not give error and raise Pragma_Exit.
+ function Appears_In
+ (List : Elist_Id;
+ Item_Id : Entity_Id) return Boolean
+ is
+ Elmt : Elmt_Id;
+ Id : Entity_Id;
- procedure Check_Arg_Is_One_Of
- (Arg : Node_Id;
- N1, N2 : Name_Id);
- procedure Check_Arg_Is_One_Of
- (Arg : Node_Id;
- N1, N2, N3 : Name_Id);
- procedure Check_Arg_Is_One_Of
- (Arg : Node_Id;
- N1, N2, N3, N4 : Name_Id);
- procedure Check_Arg_Is_One_Of
- (Arg : Node_Id;
- N1, N2, N3, N4, N5 : Name_Id);
- -- Check the specified argument Arg to make sure that it is an
- -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
- -- present). If not then give error and raise Pragma_Exit.
+ begin
+ if Present (List) then
+ Elmt := First_Elmt (List);
+ while Present (Elmt) loop
+ if Nkind (Node (Elmt)) = N_Defining_Identifier then
+ Id := Node (Elmt);
+ else
+ Id := Entity (Node (Elmt));
+ end if;
- procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
- -- Check the specified argument Arg to make sure that it is a valid
- -- queuing policy name. If not give error and raise Pragma_Exit.
+ if Id = Item_Id then
+ return True;
+ end if;
- procedure Check_Arg_Is_Static_Expression
- (Arg : Node_Id;
- Typ : Entity_Id := Empty);
- -- Check the specified argument Arg to make sure that it is a static
- -- expression of the given type (i.e. it will be analyzed and resolved
- -- using this type, which can be any valid argument to Resolve, e.g.
- -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
- -- Typ is left Empty, then any static expression is allowed.
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
- procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
- -- Check the specified argument Arg to make sure that it is a valid task
- -- dispatching policy name. If not give error and raise Pragma_Exit.
+ return False;
+ end Appears_In;
- procedure Check_Arg_Order (Names : Name_List);
- -- Checks for an instance of two arguments with identifiers for the
- -- current pragma which are not in the sequence indicated by Names,
- -- and if so, generates a fatal message about bad order of arguments.
+ ----------------------------
+ -- Check_Function_Return --
+ ----------------------------
- procedure Check_At_Least_N_Arguments (N : Nat);
- -- Check there are at least N arguments present
+ procedure Check_Function_Return is
+ begin
+ if Ekind (Subp_Id) = E_Function and then not Result_Seen then
+ Error_Msg_NE
+ ("result of & must appear in exactly one output list",
+ N, Subp_Id);
+ end if;
+ end Check_Function_Return;
- procedure Check_At_Most_N_Arguments (N : Nat);
- -- Check there are no more than N arguments present
+ ----------------
+ -- Check_Mode --
+ ----------------
- procedure Check_Component
- (Comp : Node_Id;
- UU_Typ : Entity_Id;
- In_Variant_Part : Boolean := False);
- -- Examine an Unchecked_Union component for correct use of per-object
- -- constrained subtypes, and for restrictions on finalizable components.
- -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
- -- should be set when Comp comes from a record variant.
+ procedure Check_Mode
+ (Item : Node_Id;
+ Item_Id : Entity_Id;
+ Is_Input : Boolean;
+ Self_Ref : Boolean)
+ is
+ begin
+ -- Input
- procedure Check_Test_Case;
- -- Called to process a test-case pragma. It starts with checking pragma
- -- arguments, and the rest of the treatment is similar to the one for
- -- pre- and postcondition in Check_Precondition_Postcondition, except
- -- the placement rules for the test-case pragma are stricter. These
- -- pragmas may only occur after a subprogram spec declared directly
- -- in a package spec unit. In this case, the pragma is chained to the
- -- subprogram in question (using Spec_CTC_List and Next_Pragma) and
- -- analysis of the pragma is delayed till the end of the spec. In all
- -- other cases, an error message for bad placement is given.
+ if Is_Input then
+ if Ekind (Item_Id) = E_Out_Parameter
+ or else (Global_Seen
+ and then not Appears_In (Subp_Inputs, Item_Id))
+ then
+ Error_Msg_NE
+ ("item & must have mode in or in out", Item, Item_Id);
+ end if;
- procedure Check_Duplicate_Pragma (E : Entity_Id);
- -- Check if a rep item of the same name as the current pragma is already
- -- chained as a rep pragma to the given entity. If so give a message
- -- about the duplicate, and then raise Pragma_Exit so does not return.
+ -- Self-referential output
- procedure Check_Duplicated_Export_Name (Nam : Node_Id);
- -- Nam is an N_String_Literal node containing the external name set by
- -- an Import or Export pragma (or extended Import or Export pragma).
- -- This procedure checks for possible duplications if this is the export
- -- case, and if found, issues an appropriate error message.
+ elsif Self_Ref then
- procedure Check_Expr_Is_Static_Expression
- (Expr : Node_Id;
- Typ : Entity_Id := Empty);
- -- Check the specified expression Expr to make sure that it is a static
- -- expression of the given type (i.e. it will be analyzed and resolved
- -- using this type, which can be any valid argument to Resolve, e.g.
- -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
- -- Typ is left Empty, then any static expression is allowed.
+ -- A self-referential state or variable must appear in both input
+ -- and output lists of a subprogram.
- procedure Check_First_Subtype (Arg : Node_Id);
- -- Checks that Arg, whose expression is an entity name, references a
- -- first subtype.
+ if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
+ if Global_Seen
+ and then not
+ (Appears_In (Subp_Inputs, Item_Id)
+ and then
+ Appears_In (Subp_Outputs, Item_Id))
+ then
+ Error_Msg_NE ("item & must have mode in out", Item, Item_Id);
+ end if;
- procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
- -- Checks that the given argument has an identifier, and if so, requires
- -- it to match the given identifier name. If there is no identifier, or
- -- a non-matching identifier, then an error message is given and
- -- Pragma_Exit is raised.
+ -- Self-referential parameter
- procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
- -- Checks that the given argument has an identifier, and if so, requires
- -- it to match one of the given identifier names. If there is no
- -- identifier, or a non-matching identifier, then an error message is
- -- given and Pragma_Exit is raised.
+ elsif Ekind (Item_Id) /= E_In_Out_Parameter then
+ Error_Msg_NE ("item & must have mode in out", Item, Item_Id);
+ end if;
- procedure Check_In_Main_Program;
- -- Common checks for pragmas that appear within a main program
- -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
+ -- Regular output
- procedure Check_Interrupt_Or_Attach_Handler;
- -- Common processing for first argument of pragma Interrupt_Handler or
- -- pragma Attach_Handler.
+ elsif Ekind (Item_Id) = E_In_Parameter
+ or else
+ (Global_Seen and then not Appears_In (Subp_Outputs, Item_Id))
+ then
+ Error_Msg_NE
+ ("item & must have mode out or in out", Item, Item_Id);
+ end if;
+ end Check_Mode;
- procedure Check_Loop_Pragma_Placement;
- -- Verify whether pragma Loop_Invariant or Loop_Optimize or Loop_Variant
- -- appear immediately within a construct restricted to loops.
+ -----------------
+ -- Check_Usage --
+ -----------------
- procedure Check_Is_In_Decl_Part_Or_Package_Spec;
- -- Check that pragma appears in a declarative part, or in a package
- -- specification, i.e. that it does not occur in a statement sequence
- -- in a body.
+ procedure Check_Usage
+ (Subp_Items : Elist_Id;
+ Used_Items : Elist_Id;
+ Is_Input : Boolean)
+ is
+ procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id);
+ -- Emit an error concerning the erroneous usage of an item
- procedure Check_No_Identifier (Arg : Node_Id);
- -- Checks that the given argument does not have an identifier. If
- -- an identifier is present, then an error message is issued, and
- -- Pragma_Exit is raised.
+ -----------------
+ -- Usage_Error --
+ -----------------
- procedure Check_No_Identifiers;
- -- Checks that none of the arguments to the pragma has an identifier.
- -- If any argument has an identifier, then an error message is issued,
- -- and Pragma_Exit is raised.
+ procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is
+ begin
+ if Is_Input then
+ Error_Msg_NE
+ ("item & must appear in at least one input list of aspect "
+ & "Depends", Item, Item_Id);
+ else
+ Error_Msg_NE
+ ("item & must appear in exactly one output list of aspect "
+ & "Depends", Item, Item_Id);
+ end if;
+ end Usage_Error;
- procedure Check_No_Link_Name;
- -- Checks that no link name is specified
+ -- Local variables
- procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
- -- Checks if the given argument has an identifier, and if so, requires
- -- it to match the given identifier name. If there is a non-matching
- -- identifier, then an error message is given and Pragma_Exit is raised.
+ Elmt : Elmt_Id;
+ Item : Node_Id;
+ Item_Id : Entity_Id;
- procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
- -- Checks if the given argument has an identifier, and if so, requires
- -- it to match the given identifier name. If there is a non-matching
- -- identifier, then an error message is given and Pragma_Exit is raised.
- -- In this version of the procedure, the identifier name is given as
- -- a string with lower case letters.
+ -- Start of processing for Check_Usage
- procedure Check_Precondition_Postcondition (In_Body : out Boolean);
- -- Called to process a precondition or postcondition pragma. There are
- -- three cases:
- --
- -- The pragma appears after a subprogram spec
- --
- -- If the corresponding check is not enabled, the pragma is analyzed
- -- but otherwise ignored and control returns with In_Body set False.
- --
- -- If the check is enabled, then the first step is to analyze the
- -- pragma, but this is skipped if the subprogram spec appears within
- -- a package specification (because this is the case where we delay
- -- analysis till the end of the spec). Then (whether or not it was
- -- analyzed), the pragma is chained to the subprogram in question
- -- (using Spec_PPC_List and Next_Pragma) and control returns to the
- -- caller with In_Body set False.
- --
- -- The pragma appears at the start of subprogram body declarations
- --
- -- In this case an immediate return to the caller is made with
- -- In_Body set True, and the pragma is NOT analyzed.
- --
- -- In all other cases, an error message for bad placement is given
+ begin
+ if No (Subp_Items) then
+ return;
+ end if;
- procedure Check_Static_Constraint (Constr : Node_Id);
- -- Constr is a constraint from an N_Subtype_Indication node from a
- -- component constraint in an Unchecked_Union type. This routine checks
- -- that the constraint is static as required by the restrictions for
- -- Unchecked_Union.
+ -- Each input or output of the subprogram must appear in a dependency
+ -- relation.
- procedure Check_Valid_Configuration_Pragma;
- -- Legality checks for placement of a configuration pragma
+ Elmt := First_Elmt (Subp_Items);
+ while Present (Elmt) loop
+ Item := Node (Elmt);
- procedure Check_Valid_Library_Unit_Pragma;
- -- Legality checks for library unit pragmas. A special case arises for
- -- pragmas in generic instances that come from copies of the original
- -- library unit pragmas in the generic templates. In the case of other
- -- than library level instantiations these can appear in contexts which
- -- would normally be invalid (they only apply to the original template
- -- and to library level instantiations), and they are simply ignored,
- -- which is implemented by rewriting them as null statements.
+ if Nkind (Item) = N_Defining_Identifier then
+ Item_Id := Item;
+ else
+ Item_Id := Entity (Item);
+ end if;
- procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
- -- Check an Unchecked_Union variant for lack of nested variants and
- -- presence of at least one component. UU_Typ is the related Unchecked_
- -- Union type.
+ -- The item does not appear in a dependency
- procedure Error_Pragma (Msg : String);
- pragma No_Return (Error_Pragma);
- -- Outputs error message for current pragma. The message contains a %
- -- that will be replaced with the pragma name, and the flag is placed
- -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
- -- calls Fix_Error (see spec of that procedure for details).
+ if not Contains (Used_Items, Item_Id) then
+ if Is_Formal (Item_Id) then
+ Usage_Error (Item, Item_Id);
- procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
- pragma No_Return (Error_Pragma_Arg);
- -- Outputs error message for current pragma. The message may contain
- -- a % that will be replaced with the pragma name. The parameter Arg
- -- may either be a pragma argument association, in which case the flag
- -- is placed on the expression of this association, or an expression,
- -- in which case the flag is placed directly on the expression. The
- -- message is placed using Error_Msg_N, so the message may also contain
- -- an & insertion character which will reference the given Arg value.
- -- After placing the message, Pragma_Exit is raised. Note: this routine
- -- calls Fix_Error (see spec of that procedure for details).
+ -- States and global variables are not used properly only when
+ -- the subprogram is subject to pragma Global.
- procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
- pragma No_Return (Error_Pragma_Arg);
- -- Similar to above form of Error_Pragma_Arg except that two messages
- -- are provided, the second is a continuation comment starting with \.
+ elsif Global_Seen then
+ Usage_Error (Item, Item_Id);
+ end if;
+ end if;
- procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
- pragma No_Return (Error_Pragma_Arg_Ident);
- -- Outputs error message for current pragma. The message may contain
- -- a % that will be replaced with the pragma name. The parameter Arg
- -- must be a pragma argument association with a non-empty identifier
- -- (i.e. its Chars field must be set), and the error message is placed
- -- on the identifier. The message is placed using Error_Msg_N so
- -- the message may also contain an & insertion character which will
- -- reference the identifier. After placing the message, Pragma_Exit
- -- is raised. Note: this routine calls Fix_Error (see spec of that
- -- procedure for details).
+ Next_Elmt (Elmt);
+ end loop;
+ end Check_Usage;
- procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
- pragma No_Return (Error_Pragma_Ref);
- -- Outputs error message for current pragma. The message may contain
- -- a % that will be replaced with the pragma name. The parameter Ref
- -- must be an entity whose name can be referenced by & and sloc by #.
- -- After placing the message, Pragma_Exit is raised. Note: this routine
- -- calls Fix_Error (see spec of that procedure for details).
+ ---------------------------------------
+ -- Collect_Subprogram_Inputs_Outputs --
+ ---------------------------------------
- function Find_Lib_Unit_Name return Entity_Id;
- -- Used for a library unit pragma to find the entity to which the
- -- library unit pragma applies, returns the entity found.
+ procedure Collect_Subprogram_Inputs_Outputs is
+ procedure Collect_Global_List
+ (List : Node_Id;
+ Mode : Name_Id := Name_Input);
+ -- Collect all relevant items from a global list
- procedure Find_Program_Unit_Name (Id : Node_Id);
- -- If the pragma is a compilation unit pragma, the id must denote the
- -- compilation unit in the same compilation, and the pragma must appear
- -- in the list of preceding or trailing pragmas. If it is a program
- -- unit pragma that is not a compilation unit pragma, then the
- -- identifier must be visible.
+ -------------------------
+ -- Collect_Global_List --
+ -------------------------
- function Find_Unique_Parameterless_Procedure
- (Name : Entity_Id;
- Arg : Node_Id) return Entity_Id;
- -- Used for a procedure pragma to find the unique parameterless
- -- procedure identified by Name, returns it if it exists, otherwise
- -- errors out and uses Arg as the pragma argument for the message.
+ procedure Collect_Global_List
+ (List : Node_Id;
+ Mode : Name_Id := Name_Input)
+ is
+ procedure Collect_Global_Item
+ (Item : Node_Id;
+ Mode : Name_Id);
+ -- Add an item to the proper subprogram input or output collection
- procedure Fix_Error (Msg : in out String);
- -- This is called prior to issuing an error message. Msg is a string
- -- that typically contains the substring "pragma". If the pragma comes
- -- from an aspect, each such "pragma" substring is replaced with the
- -- characters "aspect", and Error_Msg_Name_1 is set to the name of the
- -- aspect (which may be different from the pragma name). If the current
- -- pragma results from rewriting another pragma, then Error_Msg_Name_1
- -- is set to the original pragma name.
+ -------------------------
+ -- Collect_Global_Item --
+ -------------------------
- procedure Gather_Associations
- (Names : Name_List;
- Args : out Args_List);
- -- This procedure is used to gather the arguments for a pragma that
- -- permits arbitrary ordering of parameters using the normal rules
- -- for named and positional parameters. The Names argument is a list
- -- of Name_Id values that corresponds to the allowed pragma argument
- -- association identifiers in order. The result returned in Args is
- -- a list of corresponding expressions that are the pragma arguments.
- -- Note that this is a list of expressions, not of pragma argument
- -- associations (Gather_Associations has completely checked all the
- -- optional identifiers when it returns). An entry in Args is Empty
- -- on return if the corresponding argument is not present.
+ procedure Collect_Global_Item
+ (Item : Node_Id;
+ Mode : Name_Id)
+ is
+ begin
+ if Nam_In (Mode, Name_In_Out, Name_Input) then
+ Add_Item (Item, Subp_Inputs);
+ end if;
- procedure GNAT_Pragma;
- -- Called for all GNAT defined pragmas to check the relevant restriction
- -- (No_Implementation_Pragmas).
+ if Nam_In (Mode, Name_In_Out, Name_Output) then
+ Add_Item (Item, Subp_Outputs);
+ end if;
+ end Collect_Global_Item;
- procedure S14_Pragma;
- -- Called for all pragmas defined for formal verification to check that
- -- the S14_Extensions flag is set.
- -- This name needs fixing ??? There is no such thing as an
- -- "S14_Extensions" flag ???
+ -- Local variables
- function Is_Before_First_Decl
- (Pragma_Node : Node_Id;
- Decls : List_Id) return Boolean;
- -- Return True if Pragma_Node is before the first declarative item in
- -- Decls where Decls is the list of declarative items.
+ Assoc : Node_Id;
+ Item : Node_Id;
- function Is_Configuration_Pragma return Boolean;
- -- Determines if the placement of the current pragma is appropriate
- -- for a configuration pragma.
+ -- Start of processing for Collect_Global_List
- function Is_In_Context_Clause return Boolean;
- -- Returns True if pragma appears within the context clause of a unit,
- -- and False for any other placement (does not generate any messages).
+ begin
+ -- Single global item declaration
- function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
- -- Analyzes the argument, and determines if it is a static string
- -- expression, returns True if so, False if non-static or not String.
+ if Nkind_In (List, N_Identifier, N_Selected_Component) then
+ Collect_Global_Item (List, Mode);
- procedure Pragma_Misplaced;
- pragma No_Return (Pragma_Misplaced);
- -- Issue fatal error message for misplaced pragma
+ -- Simple global list or moded global list declaration
- procedure Process_Atomic_Shared_Volatile;
- -- Common processing for pragmas Atomic, Shared, Volatile. Note that
- -- Shared is an obsolete Ada 83 pragma, treated as being identical
- -- in effect to pragma Atomic.
+ else
+ if Present (Expressions (List)) then
+ Item := First (Expressions (List));
+ while Present (Item) loop
+ Collect_Global_Item (Item, Mode);
- procedure Process_Compile_Time_Warning_Or_Error;
- -- Common processing for Compile_Time_Error and Compile_Time_Warning
+ Next (Item);
+ end loop;
- procedure Process_Convention
- (C : out Convention_Id;
- Ent : out Entity_Id);
- -- Common processing for Convention, Interface, Import and Export.
- -- Checks first two arguments of pragma, and sets the appropriate
- -- convention value in the specified entity or entities. On return
- -- C is the convention, Ent is the referenced entity.
+ else
+ Assoc := First (Component_Associations (List));
+ while Present (Assoc) loop
+ Collect_Global_List
+ (List => Expression (Assoc),
+ Mode => Chars (First (Choices (Assoc))));
- procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
- -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
- -- Name_Suppress for Disable and Name_Unsuppress for Enable.
+ Next (Assoc);
+ end loop;
+ end if;
+ end if;
+ end Collect_Global_List;
- procedure Process_Extended_Import_Export_Exception_Pragma
- (Arg_Internal : Node_Id;
- Arg_External : Node_Id;
- Arg_Form : Node_Id;
- Arg_Code : Node_Id);
- -- Common processing for the pragmas Import/Export_Exception. The three
- -- arguments correspond to the three named parameters of the pragma. An
- -- argument is empty if the corresponding parameter is not present in
- -- the pragma.
+ -- Local variables
- procedure Process_Extended_Import_Export_Object_Pragma
- (Arg_Internal : Node_Id;
- Arg_External : Node_Id;
- Arg_Size : Node_Id);
- -- Common processing for the pragmas Import/Export_Object. The three
- -- arguments correspond to the three named parameters of the pragmas. An
- -- argument is empty if the corresponding parameter is not present in
- -- the pragma.
+ Formal : Entity_Id;
+ Global : Node_Id;
+ List : Node_Id;
- procedure Process_Extended_Import_Export_Internal_Arg
- (Arg_Internal : Node_Id := Empty);
- -- Common processing for all extended Import and Export pragmas. The
- -- argument is the pragma parameter for the Internal argument. If
- -- Arg_Internal is empty or inappropriate, an error message is posted.
- -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
- -- set to identify the referenced entity.
+ -- Start of processing for Collect_Subprogram_Inputs_Outputs
- procedure Process_Extended_Import_Export_Subprogram_Pragma
- (Arg_Internal : Node_Id;
- Arg_External : Node_Id;
- Arg_Parameter_Types : Node_Id;
- Arg_Result_Type : Node_Id := Empty;
- Arg_Mechanism : Node_Id;
- Arg_Result_Mechanism : Node_Id := Empty;
- Arg_First_Optional_Parameter : Node_Id := Empty);
- -- Common processing for all extended Import and Export pragmas applying
- -- to subprograms. The caller omits any arguments that do not apply to
- -- the pragma in question (for example, Arg_Result_Type can be non-Empty
- -- only in the Import_Function and Export_Function cases). The argument
- -- names correspond to the allowed pragma association identifiers.
+ begin
+ -- Process all formal parameters
- procedure Process_Generic_List;
- -- Common processing for Share_Generic and Inline_Generic
+ Formal := First_Formal (Subp_Id);
+ while Present (Formal) loop
+ if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
+ Add_Item (Formal, Subp_Inputs);
+ end if;
- procedure Process_Import_Or_Interface;
- -- Common processing for Import of Interface
+ if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
+ Add_Item (Formal, Subp_Outputs);
+ end if;
- procedure Process_Import_Predefined_Type;
- -- Processing for completing a type with pragma Import. This is used
- -- to declare types that match predefined C types, especially for cases
- -- without corresponding Ada predefined type.
+ Next_Formal (Formal);
+ end loop;
- type Inline_Status is (Suppressed, Disabled, Enabled);
- -- Inline status of a subprogram, indicated as follows:
- -- Suppressed: inlining is suppressed for the subprogram
- -- Disabled: no inlining is requested for the subprogram
- -- Enabled: inlining is requested/required for the subprogram
+ -- If the subprogram is subject to pragma Global, traverse all global
+ -- lists and gather the relevant items.
- procedure Process_Inline (Status : Inline_Status);
- -- Common processing for Inline, Inline_Always and No_Inline. Parameter
- -- indicates the inline status specified by the pragma.
+ Global := Find_Aspect (Subp_Id, Aspect_Global);
+ if Present (Global) then
+ Global_Seen := True;
- procedure Process_Interface_Name
- (Subprogram_Def : Entity_Id;
- Ext_Arg : Node_Id;
- Link_Arg : Node_Id);
- -- Given the last two arguments of pragma Import, pragma Export, or
- -- pragma Interface_Name, performs validity checks and sets the
- -- Interface_Name field of the given subprogram entity to the
- -- appropriate external or link name, depending on the arguments given.
- -- Ext_Arg is always present, but Link_Arg may be missing. Note that
- -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
- -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
- -- nor Link_Arg is present, the interface name is set to the default
- -- from the subprogram name.
+ -- Retrieve the pragma as it contains the analyzed lists
- procedure Process_Interrupt_Or_Attach_Handler;
- -- Common processing for Interrupt and Attach_Handler pragmas
+ Global := Aspect_Rep_Item (Global);
- procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
- -- Common processing for Restrictions and Restriction_Warnings pragmas.
- -- Warn is True for Restriction_Warnings, or for Restrictions if the
- -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
- -- is not set in the Restrictions case.
+ -- The pragma may not have been analyzed because of the arbitrary
+ -- declaration order of aspects. Make sure that it is analyzed for
+ -- the purposes of item extraction.
- procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
- -- Common processing for Suppress and Unsuppress. The boolean parameter
- -- Suppress_Case is True for the Suppress case, and False for the
- -- Unsuppress case.
+ if not Analyzed (Global) then
+ Analyze_Global_In_Decl_Part (Global);
+ end if;
- procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
- -- This procedure sets the Is_Exported flag for the given entity,
- -- checking that the entity was not previously imported. Arg is
- -- the argument that specified the entity. A check is also made
- -- for exporting inappropriate entities.
+ List :=
+ Expression (First (Pragma_Argument_Associations (Global)));
- procedure Set_Extended_Import_Export_External_Name
- (Internal_Ent : Entity_Id;
- Arg_External : Node_Id);
- -- Common processing for all extended import export pragmas. The first
- -- argument, Internal_Ent, is the internal entity, which has already
- -- been checked for validity by the caller. Arg_External is from the
- -- Import or Export pragma, and may be null if no External parameter
- -- was present. If Arg_External is present and is a non-null string
- -- (a null string is treated as the default), then the Interface_Name
- -- field of Internal_Ent is set appropriately.
+ -- Nothing to be done for a null global list
- procedure Set_Imported (E : Entity_Id);
- -- This procedure sets the Is_Imported flag for the given entity,
- -- checking that it is not previously exported or imported.
+ if Nkind (List) /= N_Null then
+ Collect_Global_List (List);
+ end if;
+ end if;
+ end Collect_Subprogram_Inputs_Outputs;
- procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
- -- Mech is a parameter passing mechanism (see Import_Function syntax
- -- for MECHANISM_NAME). This routine checks that the mechanism argument
- -- has the right form, and if not issues an error message. If the
- -- argument has the right form then the Mechanism field of Ent is
- -- set appropriately.
+ ----------------------
+ -- Normalize_Clause --
+ ----------------------
- procedure Set_Rational_Profile;
- -- Activate the set of configuration pragmas and permissions that make
- -- up the Rational profile.
+ procedure Normalize_Clause (Clause : Node_Id) is
+ procedure Create_Or_Modify_Clause
+ (Output : Node_Id;
+ Outputs : Node_Id;
+ Inputs : Node_Id;
+ After : Node_Id;
+ In_Place : Boolean;
+ Multiple : Boolean);
+ -- Create a brand new clause to represent the self-reference or
+ -- modify the input and/or output lists of an existing clause. Output
+ -- denotes a self-referencial output. Outputs is the output list of a
+ -- clause. Inputs is the input list of a clause. After denotes the
+ -- clause after which the new clause is to be inserted. Flag In_Place
+ -- should be set when normalizing the last output of an output list.
+ -- Flag Multiple should be set when Output comes from a list with
+ -- multiple items.
- procedure Set_Ravenscar_Profile (N : Node_Id);
- -- Activate the set of configuration pragmas and restrictions that make
- -- up the Ravenscar Profile. N is the corresponding pragma node, which
- -- is used for error messages on any constructs that violate the
- -- profile.
+ -----------------------------
+ -- Create_Or_Modify_Clause --
+ -----------------------------
- ---------------------
- -- Ada_2005_Pragma --
- ---------------------
+ procedure Create_Or_Modify_Clause
+ (Output : Node_Id;
+ Outputs : Node_Id;
+ Inputs : Node_Id;
+ After : Node_Id;
+ In_Place : Boolean;
+ Multiple : Boolean)
+ is
+ procedure Propagate_Output
+ (Output : Node_Id;
+ Inputs : Node_Id);
+ -- Handle the various cases of output propagation to the input
+ -- list. Output denotes a self-referencial output item. Inputs is
+ -- the input list of a clause.
- procedure Ada_2005_Pragma is
- begin
- if Ada_Version <= Ada_95 then
- Check_Restriction (No_Implementation_Pragmas, N);
- end if;
- end Ada_2005_Pragma;
+ ----------------------
+ -- Propagate_Output --
+ ----------------------
- ---------------------
- -- Ada_2012_Pragma --
- ---------------------
+ procedure Propagate_Output
+ (Output : Node_Id;
+ Inputs : Node_Id)
+ is
+ function In_Input_List
+ (Item : Entity_Id;
+ Inputs : List_Id) return Boolean;
+ -- Determine whether a particulat item appears in the input
+ -- list of a clause.
+
+ -------------------
+ -- In_Input_List --
+ -------------------
+
+ function In_Input_List
+ (Item : Entity_Id;
+ Inputs : List_Id) return Boolean
+ is
+ Elmt : Node_Id;
- procedure Ada_2012_Pragma is
- begin
- if Ada_Version <= Ada_2005 then
- Check_Restriction (No_Implementation_Pragmas, N);
- end if;
- end Ada_2012_Pragma;
+ begin
+ Elmt := First (Inputs);
+ while Present (Elmt) loop
+ if Entity_Of (Elmt) = Item then
+ return True;
+ end if;
- --------------
- -- Add_Item --
- --------------
+ Next (Elmt);
+ end loop;
- procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is
- begin
- if No (To_List) then
- To_List := New_Elmt_List;
- end if;
+ return False;
+ end In_Input_List;
- Append_Unique_Elmt (Item, To_List);
- end Add_Item;
+ -- Local variables
- --------------------------
- -- Check_Ada_83_Warning --
- --------------------------
+ Output_Id : constant Entity_Id := Entity_Of (Output);
+ Grouped : List_Id;
- procedure Check_Ada_83_Warning is
- begin
- if Ada_Version = Ada_83 and then Comes_From_Source (N) then
- Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
- end if;
- end Check_Ada_83_Warning;
+ -- Start of processing for Propagate_Output
- ---------------------
- -- Check_Arg_Count --
- ---------------------
+ begin
+ -- The clause is of the form:
- procedure Check_Arg_Count (Required : Nat) is
- begin
- if Arg_Count /= Required then
- Error_Pragma ("wrong number of arguments for pragma%");
- end if;
- end Check_Arg_Count;
+ -- (Output =>+ null)
- --------------------------------
- -- Check_Arg_Is_External_Name --
- --------------------------------
+ -- Remove the null input and replace it with a copy of the
+ -- output:
- procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ -- (Output => Output)
- begin
- if Nkind (Argx) = N_Identifier then
- return;
+ if Nkind (Inputs) = N_Null then
+ Rewrite (Inputs, New_Copy_Tree (Output));
- else
- Analyze_And_Resolve (Argx, Standard_String);
+ -- The clause is of the form:
- if Is_OK_Static_Expression (Argx) then
- return;
+ -- (Output =>+ (Input1, ..., InputN))
- elsif Etype (Argx) = Any_Type then
- raise Pragma_Exit;
+ -- Determine whether the output is not already mentioned in the
+ -- input list and if not, add it to the list of inputs:
- -- An interesting special case, if we have a string literal and
- -- we are in Ada 83 mode, then we allow it even though it will
- -- not be flagged as static. This allows expected Ada 83 mode
- -- use of external names which are string literals, even though
- -- technically these are not static in Ada 83.
+ -- (Output => (Output, Input1, ..., InputN))
- elsif Ada_Version = Ada_83
- and then Nkind (Argx) = N_String_Literal
- then
- return;
+ elsif Nkind (Inputs) = N_Aggregate then
+ Grouped := Expressions (Inputs);
- -- Static expression that raises Constraint_Error. This has
- -- already been flagged, so just exit from pragma processing.
+ if not In_Input_List
+ (Item => Output_Id,
+ Inputs => Grouped)
+ then
+ Prepend_To (Grouped, New_Copy_Tree (Output));
+ end if;
- elsif Is_Static_Expression (Argx) then
- raise Pragma_Exit;
+ -- The clause is of the form:
- -- Here we have a real error (non-static expression)
+ -- (Output =>+ Input)
- else
- Error_Msg_Name_1 := Pname;
+ -- If the input does not mention the output, group the two
+ -- together:
- declare
- Msg : String :=
- "argument for pragma% must be a identifier or "
- & "static string expression!";
- begin
- Fix_Error (Msg);
- Flag_Non_Static_Expr (Msg, Argx);
- raise Pragma_Exit;
- end;
- end if;
- end if;
- end Check_Arg_Is_External_Name;
+ -- (Output => (Output, Input))
- -----------------------------
- -- Check_Arg_Is_Identifier --
- -----------------------------
+ elsif Entity_Of (Inputs) /= Output_Id then
+ Rewrite (Inputs,
+ Make_Aggregate (Loc,
+ Expressions => New_List (
+ New_Copy_Tree (Output),
+ New_Copy_Tree (Inputs))));
+ end if;
+ end Propagate_Output;
- procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
- begin
- if Nkind (Argx) /= N_Identifier then
- Error_Pragma_Arg
- ("argument for pragma% must be identifier", Argx);
- end if;
- end Check_Arg_Is_Identifier;
+ -- Local variables
- ----------------------------------
- -- Check_Arg_Is_Integer_Literal --
- ----------------------------------
+ Loc : constant Source_Ptr := Sloc (Output);
+ Clause : Node_Id;
- procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
- begin
- if Nkind (Argx) /= N_Integer_Literal then
- Error_Pragma_Arg
- ("argument for pragma% must be integer literal", Argx);
- end if;
- end Check_Arg_Is_Integer_Literal;
+ -- Start of processing for Create_Or_Modify_Clause
- -------------------------------------------
- -- Check_Arg_Is_Library_Level_Local_Name --
- -------------------------------------------
+ begin
+ -- A function result cannot depend on itself because it cannot
+ -- appear in the input list of a relation.
- -- LOCAL_NAME ::=
- -- DIRECT_NAME
- -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
- -- | library_unit_NAME
+ if Nkind (Output) = N_Attribute_Reference
+ and then Attribute_Name (Output) = Name_Result
+ then
+ Error_Msg_N ("function result cannot depend on itself", Output);
+ return;
- procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
- begin
- Check_Arg_Is_Local_Name (Arg);
+ -- A null output depending on itself does not require any
+ -- normalization.
- if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
- and then Comes_From_Source (N)
- then
- Error_Pragma_Arg
- ("argument for pragma% must be library level entity", Arg);
- end if;
- end Check_Arg_Is_Library_Level_Local_Name;
+ elsif Nkind (Output) = N_Null then
+ return;
+ end if;
- -----------------------------
- -- Check_Arg_Is_Local_Name --
- -----------------------------
+ -- When performing the transformation in place, simply add the
+ -- output to the list of inputs (if not already there). This case
+ -- arises when dealing with the last output of an output list -
+ -- we perform the normalization in place to avoid generating a
+ -- malformed tree.
- -- LOCAL_NAME ::=
- -- DIRECT_NAME
- -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
- -- | library_unit_NAME
+ if In_Place then
+ Propagate_Output (Output, Inputs);
- procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ -- A list with multiple outputs is slowly trimmed until only
+ -- one element remains. When this happens, replace the
+ -- aggregate with the element itself.
- begin
- Analyze (Argx);
+ if Multiple then
+ Remove (Output);
+ Rewrite (Outputs, Output);
+ end if;
- if Nkind (Argx) not in N_Direct_Name
- and then (Nkind (Argx) /= N_Attribute_Reference
- or else Present (Expressions (Argx))
- or else Nkind (Prefix (Argx)) /= N_Identifier)
- and then (not Is_Entity_Name (Argx)
- or else not Is_Compilation_Unit (Entity (Argx)))
- then
- Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
- end if;
+ -- Default case
- -- No further check required if not an entity name
+ else
+ -- Unchain the output from its output list as it will appear in
+ -- a new clause. Note that we cannot simply rewrite the output
+ -- as null because this will violate the semantics of aspect or
+ -- pragma Depends.
- if not Is_Entity_Name (Argx) then
- null;
+ Remove (Output);
- else
- declare
- OK : Boolean;
- Ent : constant Entity_Id := Entity (Argx);
- Scop : constant Entity_Id := Scope (Ent);
+ -- Create a new clause of the form:
- begin
- -- Case of a pragma applied to a compilation unit: pragma must
- -- occur immediately after the program unit in the compilation.
+ -- (Output => Inputs)
- if Is_Compilation_Unit (Ent) then
- declare
- Decl : constant Node_Id := Unit_Declaration_Node (Ent);
+ Clause :=
+ Make_Component_Association (Loc,
+ Choices => New_List (Output),
+ Expression => New_Copy_Tree (Inputs));
- begin
- -- Case of pragma placed immediately after spec
+ -- The new clause contains replicated content that has already
+ -- been analyzed. There is not need to reanalyze it or
+ -- renormalize it again.
- if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
- OK := True;
+ Set_Analyzed (Clause);
- -- Case of pragma placed immediately after body
+ Propagate_Output
+ (Output => First (Choices (Clause)),
+ Inputs => Expression (Clause));
- elsif Nkind (Decl) = N_Subprogram_Declaration
- and then Present (Corresponding_Body (Decl))
- then
- OK := Parent (N) =
- Aux_Decls_Node
- (Parent (Unit_Declaration_Node
- (Corresponding_Body (Decl))));
+ Insert_After (After, Clause);
+ end if;
+ end Create_Or_Modify_Clause;
- -- All other cases are illegal
+ -- Local variables
- else
- OK := False;
- end if;
- end;
+ Outputs : constant Node_Id := First (Choices (Clause));
+ Inputs : Node_Id;
+ Last_Output : Node_Id;
+ Next_Output : Node_Id;
+ Output : Node_Id;
- -- Special restricted placement rule from 10.2.1(11.8/2)
+ -- Start of processing for Normalize_Clause
- elsif Is_Generic_Formal (Ent)
- and then Prag_Id = Pragma_Preelaborable_Initialization
- then
- OK := List_Containing (N) =
- Generic_Formal_Declarations
- (Unit_Declaration_Node (Scop));
+ begin
+ -- A self-dependency appears as operator "+". Remove the "+" from the
+ -- tree by moving the real inputs to their proper place.
- -- Default case, just check that the pragma occurs in the scope
- -- of the entity denoted by the name.
+ if Nkind (Expression (Clause)) = N_Op_Plus then
+ Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
+ Inputs := Expression (Clause);
- else
- OK := Current_Scope = Scop;
- end if;
+ -- Multiple outputs appear as an aggregate
- if not OK then
- Error_Pragma_Arg
- ("pragma% argument must be in same declarative part", Arg);
- end if;
- end;
- end if;
- end Check_Arg_Is_Local_Name;
+ if Nkind (Outputs) = N_Aggregate then
+ Last_Output := Last (Expressions (Outputs));
- ---------------------------------
- -- Check_Arg_Is_Locking_Policy --
- ---------------------------------
+ Output := First (Expressions (Outputs));
+ while Present (Output) loop
- procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ -- Normalization may remove an output from its list,
+ -- preserve the subsequent output now.
- begin
- Check_Arg_Is_Identifier (Argx);
+ Next_Output := Next (Output);
- if not Is_Locking_Policy_Name (Chars (Argx)) then
- Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
+ Create_Or_Modify_Clause
+ (Output => Output,
+ Outputs => Outputs,
+ Inputs => Inputs,
+ After => Clause,
+ In_Place => Output = Last_Output,
+ Multiple => True);
+
+ Output := Next_Output;
+ end loop;
+
+ -- Solitary output
+
+ else
+ Create_Or_Modify_Clause
+ (Output => Outputs,
+ Outputs => Empty,
+ Inputs => Inputs,
+ After => Empty,
+ In_Place => True,
+ Multiple => False);
+ end if;
end if;
- end Check_Arg_Is_Locking_Policy;
+ end Normalize_Clause;
- -----------------------------------------------
- -- Check_Arg_Is_Partition_Elaboration_Policy --
- -----------------------------------------------
+ -- Local variables
- procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ Clause : Node_Id;
+ Errors : Nat;
+ Last_Clause : Node_Id;
+ Subp_Decl : Node_Id;
- begin
- Check_Arg_Is_Identifier (Argx);
+ -- Start of processing for Analyze_Depends_In_Decl_Part
- if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
- Error_Pragma_Arg
- ("& is not a valid partition elaboration policy name", Argx);
- end if;
- end Check_Arg_Is_Partition_Elaboration_Policy;
+ begin
+ Set_Analyzed (N);
- -------------------------
- -- Check_Arg_Is_One_Of --
- -------------------------
+ Subp_Decl := Parent (Corresponding_Aspect (N));
+ Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
+ Clause := Expression (Arg1);
- procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ -- Empty dependency list
- begin
- Check_Arg_Is_Identifier (Argx);
+ if Nkind (Clause) = N_Null then
- if not Nam_In (Chars (Argx), N1, N2) then
- Error_Msg_Name_2 := N1;
- Error_Msg_Name_3 := N2;
- Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
- end if;
- end Check_Arg_Is_One_Of;
+ -- Gather all states, variables and formal parameters that the
+ -- subprogram may depend on. These items are obtained from the
+ -- parameter profile or pragma Global (if available).
- procedure Check_Arg_Is_One_Of
- (Arg : Node_Id;
- N1, N2, N3 : Name_Id)
- is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ Collect_Subprogram_Inputs_Outputs;
- begin
- Check_Arg_Is_Identifier (Argx);
+ -- Verify that every input or output of the subprogram appear in a
+ -- dependency.
- if not Nam_In (Chars (Argx), N1, N2, N3) then
- Error_Pragma_Arg ("invalid argument for pragma%", Argx);
- end if;
- end Check_Arg_Is_One_Of;
+ Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
+ Check_Usage (Subp_Outputs, Outputs_Seen, False);
+ Check_Function_Return;
- procedure Check_Arg_Is_One_Of
- (Arg : Node_Id;
- N1, N2, N3, N4 : Name_Id)
- is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ -- Dependency clauses appear as component associations of an aggregate
- begin
- Check_Arg_Is_Identifier (Argx);
+ elsif Nkind (Clause) = N_Aggregate
+ and then Present (Component_Associations (Clause))
+ then
+ Last_Clause := Last (Component_Associations (Clause));
- if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
- Error_Pragma_Arg ("invalid argument for pragma%", Argx);
- end if;
- end Check_Arg_Is_One_Of;
+ -- Gather all states, variables and formal parameters that the
+ -- subprogram may depend on. These items are obtained from the
+ -- parameter profile or pragma Global (if available).
- procedure Check_Arg_Is_One_Of
- (Arg : Node_Id;
- N1, N2, N3, N4, N5 : Name_Id)
- is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ Collect_Subprogram_Inputs_Outputs;
- begin
- Check_Arg_Is_Identifier (Argx);
+ -- Ensure that the formal parameters are visible when analyzing all
+ -- clauses. This falls out of the general rule of aspects pertaining
+ -- to subprogram declarations. Skip the installation for subprogram
+ -- bodies because the formals are already visible.
- if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
- Error_Pragma_Arg ("invalid argument for pragma%", Argx);
+ if Nkind (Subp_Decl) = N_Subprogram_Declaration then
+ Push_Scope (Subp_Id);
+ Install_Formals (Subp_Id);
end if;
- end Check_Arg_Is_One_Of;
- ---------------------------------
- -- Check_Arg_Is_Queuing_Policy --
- ---------------------------------
+ Clause := First (Component_Associations (Clause));
+ while Present (Clause) loop
+ Errors := Serious_Errors_Detected;
- procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ -- Normalization may create extra clauses that contain replicated
+ -- input and output names. There is no need to reanalyze or
+ -- renormalize these extra clauses.
- begin
- Check_Arg_Is_Identifier (Argx);
+ if not Analyzed (Clause) then
+ Set_Analyzed (Clause);
- if not Is_Queuing_Policy_Name (Chars (Argx)) then
- Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
- end if;
- end Check_Arg_Is_Queuing_Policy;
-
- ------------------------------------
- -- Check_Arg_Is_Static_Expression --
- ------------------------------------
-
- procedure Check_Arg_Is_Static_Expression
- (Arg : Node_Id;
- Typ : Entity_Id := Empty)
- is
- begin
- Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ);
- end Check_Arg_Is_Static_Expression;
+ Analyze_Dependency_Clause
+ (Clause => Clause,
+ Is_Last => Clause = Last_Clause);
- ------------------------------------------
- -- Check_Arg_Is_Task_Dispatching_Policy --
- ------------------------------------------
+ -- Do not normalize an erroneous clause because the inputs or
+ -- outputs may denote illegal items.
- procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ if Errors = Serious_Errors_Detected then
+ Normalize_Clause (Clause);
+ end if;
+ end if;
- begin
- Check_Arg_Is_Identifier (Argx);
+ Next (Clause);
+ end loop;
- if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
- Error_Pragma_Arg
- ("& is not a valid task dispatching policy name", Argx);
+ if Nkind (Subp_Decl) = N_Subprogram_Declaration then
+ End_Scope;
end if;
- end Check_Arg_Is_Task_Dispatching_Policy;
- ---------------------
- -- Check_Arg_Order --
- ---------------------
+ -- Verify that every input or output of the subprogram appear in a
+ -- dependency.
- procedure Check_Arg_Order (Names : Name_List) is
- Arg : Node_Id;
+ Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
+ Check_Usage (Subp_Outputs, Outputs_Seen, False);
+ Check_Function_Return;
- Highest_So_Far : Natural := 0;
- -- Highest index in Names seen do far
+ -- The top level dependency relation is malformed
- begin
- Arg := Arg1;
- for J in 1 .. Arg_Count loop
- if Chars (Arg) /= No_Name then
- for K in Names'Range loop
- if Chars (Arg) = Names (K) then
- if K < Highest_So_Far then
- Error_Msg_Name_1 := Pname;
- Error_Msg_N
- ("parameters out of order for pragma%", Arg);
- Error_Msg_Name_1 := Names (K);
- Error_Msg_Name_2 := Names (Highest_So_Far);
- Error_Msg_N ("\% must appear before %", Arg);
- raise Pragma_Exit;
+ else
+ Error_Msg_N ("malformed dependency relation", Clause);
+ end if;
+ end Analyze_Depends_In_Decl_Part;
- else
- Highest_So_Far := K;
- end if;
- end if;
- end loop;
- end if;
+ ---------------------------------
+ -- Analyze_Global_In_Decl_Part --
+ ---------------------------------
- Arg := Next (Arg);
- end loop;
- end Check_Arg_Order;
+ procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
+ Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
- --------------------------------
- -- Check_At_Least_N_Arguments --
- --------------------------------
+ Seen : Elist_Id := No_Elist;
+ -- A list containing the entities of all the items processed so far. It
+ -- plays a role in detecting distinct entities.
- procedure Check_At_Least_N_Arguments (N : Nat) is
- begin
- if Arg_Count < N then
- Error_Pragma ("too few arguments for pragma%");
- end if;
- end Check_At_Least_N_Arguments;
+ Subp_Id : Entity_Id;
+ -- The entity of the subprogram subject to pragma Global
- -------------------------------
- -- Check_At_Most_N_Arguments --
- -------------------------------
+ Contract_Seen : Boolean := False;
+ In_Out_Seen : Boolean := False;
+ Input_Seen : Boolean := False;
+ Output_Seen : Boolean := False;
+ -- Flags used to verify the consistency of modes
- procedure Check_At_Most_N_Arguments (N : Nat) is
- Arg : Node_Id;
- begin
- if Arg_Count > N then
- Arg := Arg1;
- for J in 1 .. N loop
- Next (Arg);
- Error_Pragma_Arg ("too many arguments for pragma%", Arg);
- end loop;
- end if;
- end Check_At_Most_N_Arguments;
+ procedure Analyze_Global_List
+ (List : Node_Id;
+ Global_Mode : Name_Id := Name_Input);
+ -- Verify the legality of a single global list declaration. Global_Mode
+ -- denotes the current mode in effect.
- ---------------------
- -- Check_Component --
- ---------------------
+ -------------------------
+ -- Analyze_Global_List --
+ -------------------------
- procedure Check_Component
- (Comp : Node_Id;
- UU_Typ : Entity_Id;
- In_Variant_Part : Boolean := False)
+ procedure Analyze_Global_List
+ (List : Node_Id;
+ Global_Mode : Name_Id := Name_Input)
is
- Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
- Sindic : constant Node_Id :=
- Subtype_Indication (Component_Definition (Comp));
- Typ : constant Entity_Id := Etype (Comp_Id);
+ procedure Analyze_Global_Item
+ (Item : Node_Id;
+ Global_Mode : Name_Id);
+ -- Verify the legality of a single global item declaration.
+ -- Global_Mode denotes the current mode in effect.
+
+ procedure Check_Duplicate_Mode
+ (Mode : Node_Id;
+ Status : in out Boolean);
+ -- Flag Status denotes whether a particular mode has been seen while
+ -- processing a global list. This routine verifies that Mode is not a
+ -- duplicate mode and sets the flag Status.
+
+ procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
+ -- Mode denotes either In_Out or Output. Depending on the kind of the
+ -- related subprogram, emit an error if those two modes apply to a
+ -- function.
- begin
- -- Ada 2005 (AI-216): If a component subtype is subject to a per-
- -- object constraint, then the component type shall be an Unchecked_
- -- Union.
+ -------------------------
+ -- Analyze_Global_Item --
+ -------------------------
- if Nkind (Sindic) = N_Subtype_Indication
- and then Has_Per_Object_Constraint (Comp_Id)
- and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
- then
- Error_Msg_N
- ("component subtype subject to per-object constraint "
- & "must be an Unchecked_Union", Comp);
+ procedure Analyze_Global_Item
+ (Item : Node_Id;
+ Global_Mode : Name_Id)
+ is
+ Item_Id : Entity_Id;
- -- Ada 2012 (AI05-0026): For an unchecked union type declared within
- -- the body of a generic unit, or within the body of any of its
- -- descendant library units, no part of the type of a component
- -- declared in a variant_part of the unchecked union type shall be of
- -- a formal private type or formal private extension declared within
- -- the formal part of the generic unit.
+ begin
+ -- Detect one of the following cases
- elsif Ada_Version >= Ada_2012
- and then In_Generic_Body (UU_Typ)
- and then In_Variant_Part
- and then Is_Private_Type (Typ)
- and then Is_Generic_Type (Typ)
- then
- Error_Msg_N
- ("component of unchecked union cannot be of generic type", Comp);
+ -- with Global => (null, Name)
+ -- with Global => (Name_1, null, Name_2)
+ -- with Global => (Name, null)
- elsif Needs_Finalization (Typ) then
- Error_Msg_N
- ("component of unchecked union cannot be controlled", Comp);
+ if Nkind (Item) = N_Null then
+ Error_Msg_N ("cannot mix null and non-null global items", Item);
+ return;
+ end if;
- elsif Has_Task (Typ) then
- Error_Msg_N
- ("component of unchecked union cannot have tasks", Comp);
- end if;
- end Check_Component;
+ Analyze (Item);
- ----------------------------
- -- Check_Duplicate_Pragma --
- ----------------------------
+ -- Find the entity of the item. If this is a renaming, climb the
+ -- renaming chain to reach the root object. Renamings of non-
+ -- entire objects do not yield an entity (Empty).
- procedure Check_Duplicate_Pragma (E : Entity_Id) is
- Id : Entity_Id := E;
- P : Node_Id;
+ Item_Id := Entity_Of (Item);
- begin
- -- Nothing to do if this pragma comes from an aspect specification,
- -- since we could not be duplicating a pragma, and we dealt with the
- -- case of duplicated aspects in Analyze_Aspect_Specifications.
+ if Present (Item_Id) then
- if From_Aspect_Specification (N) then
- return;
- end if;
+ -- A global item cannot reference a formal parameter. Do this
+ -- check first to provide a better error diagnostic.
- -- Otherwise current pragma may duplicate previous pragma or a
- -- previously given aspect specification or attribute definition
- -- clause for the same pragma.
+ if Is_Formal (Item_Id) then
+ Error_Msg_N
+ ("global item cannot reference formal parameter", Item);
+ return;
- P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
+ -- The only legal references are those to abstract states and
+ -- variables.
- if Present (P) then
- Error_Msg_Name_1 := Pragma_Name (N);
- Error_Msg_Sloc := Sloc (P);
+ elsif not Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
+ Error_Msg_N
+ ("global item must denote variable or state", Item);
+ return;
+ end if;
- -- For a single protected or a single task object, the error is
- -- issued on the original entity.
+ -- When the item renames an entire object, replace the item
+ -- with a reference to the object.
- if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
- Id := Defining_Identifier (Original_Node (Parent (Id)));
- end if;
+ if Present (Renamed_Object (Entity (Item))) then
+ Rewrite (Item, New_Reference_To (Item_Id, Sloc (Item)));
+ Analyze (Item);
+ end if;
+
+ -- Some form of illegal construct masquerading as a name
- if Nkind (P) = N_Aspect_Specification
- or else From_Aspect_Specification (P)
- then
- Error_Msg_NE ("aspect% for & previously given#", N, Id);
else
- Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
+ Error_Msg_N ("global item must denote variable or state", Item);
+ return;
end if;
- raise Pragma_Exit;
- end if;
- end Check_Duplicate_Pragma;
+ -- The same entity might be referenced through various way. Check
+ -- the entity of the item rather than the item itself.
- ----------------------------------
- -- Check_Duplicated_Export_Name --
- ----------------------------------
+ if Contains (Seen, Item_Id) then
+ Error_Msg_N ("duplicate global item", Item);
- procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
- String_Val : constant String_Id := Strval (Nam);
+ -- Add the entity of the current item to the list of processed
+ -- items.
- begin
- -- We are only interested in the export case, and in the case of
- -- generics, it is the instance, not the template, that is the
- -- problem (the template will generate a warning in any case).
+ else
+ Add_Item (Item_Id, Seen);
+ end if;
- if not Inside_A_Generic
- and then (Prag_Id = Pragma_Export
- or else
- Prag_Id = Pragma_Export_Procedure
- or else
- Prag_Id = Pragma_Export_Valued_Procedure
- or else
- Prag_Id = Pragma_Export_Function)
- then
- for J in Externals.First .. Externals.Last loop
- if String_Equal (String_Val, Strval (Externals.Table (J))) then
- Error_Msg_Sloc := Sloc (Externals.Table (J));
- Error_Msg_N ("external name duplicates name given#", Nam);
- exit;
+ if Ekind (Item_Id) = E_Abstract_State
+ and then Is_Volatile_State (Item_Id)
+ then
+ -- A global item of mode In_Out or Output cannot denote a
+ -- volatile Input state.
+
+ if Is_Input_State (Item_Id)
+ and then Nam_In (Global_Mode, Name_In_Out, Name_Output)
+ then
+ Error_Msg_N
+ ("global item of mode In_Out or Output cannot reference "
+ & "Volatile Input state", Item);
+
+ -- A global item of mode In_Out or Input cannot reference a
+ -- volatile Output state.
+
+ elsif Is_Output_State (Item_Id)
+ and then Nam_In (Global_Mode, Name_In_Out, Name_Input)
+ then
+ Error_Msg_N
+ ("global item of mode In_Out or Input cannot reference "
+ & "Volatile Output state", Item);
end if;
- end loop;
+ end if;
+ end Analyze_Global_Item;
- Externals.Append (Nam);
- end if;
- end Check_Duplicated_Export_Name;
+ --------------------------
+ -- Check_Duplicate_Mode --
+ --------------------------
- -------------------------------------
- -- Check_Expr_Is_Static_Expression --
- -------------------------------------
+ procedure Check_Duplicate_Mode
+ (Mode : Node_Id;
+ Status : in out Boolean)
+ is
+ begin
+ if Status then
+ Error_Msg_N ("duplicate global mode", Mode);
+ end if;
- procedure Check_Expr_Is_Static_Expression
- (Expr : Node_Id;
- Typ : Entity_Id := Empty)
- is
- begin
- if Present (Typ) then
- Analyze_And_Resolve (Expr, Typ);
- else
- Analyze_And_Resolve (Expr);
- end if;
+ Status := True;
+ end Check_Duplicate_Mode;
- if Is_OK_Static_Expression (Expr) then
- return;
+ ----------------------------------------
+ -- Check_Mode_Restriction_In_Function --
+ ----------------------------------------
- elsif Etype (Expr) = Any_Type then
- raise Pragma_Exit;
+ procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
+ begin
+ if Ekind (Subp_Id) = E_Function then
+ Error_Msg_N
+ ("global mode & not applicable to functions", Mode);
+ end if;
+ end Check_Mode_Restriction_In_Function;
- -- An interesting special case, if we have a string literal and we
- -- are in Ada 83 mode, then we allow it even though it will not be
- -- flagged as static. This allows the use of Ada 95 pragmas like
- -- Import in Ada 83 mode. They will of course be flagged with
- -- warnings as usual, but will not cause errors.
+ -- Local variables
- elsif Ada_Version = Ada_83
- and then Nkind (Expr) = N_String_Literal
- then
- return;
+ Assoc : Node_Id;
+ Item : Node_Id;
+ Mode : Node_Id;
- -- Static expression that raises Constraint_Error. This has already
- -- been flagged, so just exit from pragma processing.
-
- elsif Is_Static_Expression (Expr) then
- raise Pragma_Exit;
-
- -- Finally, we have a real error
-
- else
- Error_Msg_Name_1 := Pname;
-
- declare
- Msg : String :=
- "argument for pragma% must be a static expression!";
- begin
- Fix_Error (Msg);
- Flag_Non_Static_Expr (Msg, Expr);
- end;
-
- raise Pragma_Exit;
- end if;
- end Check_Expr_Is_Static_Expression;
-
- -------------------------
- -- Check_First_Subtype --
- -------------------------
-
- procedure Check_First_Subtype (Arg : Node_Id) is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
- Ent : constant Entity_Id := Entity (Argx);
+ -- Start of processing for Analyze_Global_List
begin
- if Is_First_Subtype (Ent) then
- null;
+ -- Single global item declaration
- elsif Is_Type (Ent) then
- Error_Pragma_Arg
- ("pragma% cannot apply to subtype", Argx);
+ if Nkind_In (List, N_Identifier, N_Selected_Component) then
+ Analyze_Global_Item (List, Global_Mode);
- elsif Is_Object (Ent) then
- Error_Pragma_Arg
- ("pragma% cannot apply to object, requires a type", Argx);
+ -- Simple global list or moded global list declaration
- else
- Error_Pragma_Arg
- ("pragma% cannot apply to&, requires a type", Argx);
- end if;
- end Check_First_Subtype;
+ elsif Nkind (List) = N_Aggregate then
- ----------------------
- -- Check_Identifier --
- ----------------------
+ -- The declaration of a simple global list appear as a collection
+ -- of expressions.
- procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
- begin
- if Present (Arg)
- and then Nkind (Arg) = N_Pragma_Argument_Association
- then
- if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
- Error_Msg_Name_1 := Pname;
- Error_Msg_Name_2 := Id;
- Error_Msg_N ("pragma% argument expects identifier%", Arg);
- raise Pragma_Exit;
- end if;
- end if;
- end Check_Identifier;
+ if Present (Expressions (List)) then
+ if Present (Component_Associations (List)) then
+ Error_Msg_N
+ ("cannot mix moded and non-moded global lists", List);
+ end if;
- --------------------------------
- -- Check_Identifier_Is_One_Of --
- --------------------------------
+ Item := First (Expressions (List));
+ while Present (Item) loop
+ Analyze_Global_Item (Item, Global_Mode);
- procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
- begin
- if Present (Arg)
- and then Nkind (Arg) = N_Pragma_Argument_Association
- then
- if Chars (Arg) = No_Name then
- Error_Msg_Name_1 := Pname;
- Error_Msg_N ("pragma% argument expects an identifier", Arg);
- raise Pragma_Exit;
+ Next (Item);
+ end loop;
- elsif Chars (Arg) /= N1
- and then Chars (Arg) /= N2
- then
- Error_Msg_Name_1 := Pname;
- Error_Msg_N ("invalid identifier for pragma% argument", Arg);
- raise Pragma_Exit;
- end if;
- end if;
- end Check_Identifier_Is_One_Of;
+ -- The declaration of a moded global list appears as a collection
+ -- of component associations where individual choices denote
+ -- modes.
- ---------------------------
- -- Check_In_Main_Program --
- ---------------------------
+ elsif Present (Component_Associations (List)) then
+ if Present (Expressions (List)) then
+ Error_Msg_N
+ ("cannot mix moded and non-moded global lists", List);
+ end if;
- procedure Check_In_Main_Program is
- P : constant Node_Id := Parent (N);
+ Assoc := First (Component_Associations (List));
+ while Present (Assoc) loop
+ Mode := First (Choices (Assoc));
- begin
- -- Must be at in subprogram body
+ if Nkind (Mode) = N_Identifier then
+ if Chars (Mode) = Name_Contract_In then
+ Check_Duplicate_Mode (Mode, Contract_Seen);
- if Nkind (P) /= N_Subprogram_Body then
- Error_Pragma ("% pragma allowed only in subprogram");
+ elsif Chars (Mode) = Name_In_Out then
+ Check_Duplicate_Mode (Mode, In_Out_Seen);
+ Check_Mode_Restriction_In_Function (Mode);
- -- Otherwise warn if obviously not main program
+ elsif Chars (Mode) = Name_Input then
+ Check_Duplicate_Mode (Mode, Input_Seen);
- elsif Present (Parameter_Specifications (Specification (P)))
- or else not Is_Compilation_Unit (Defining_Entity (P))
- then
- Error_Msg_Name_1 := Pname;
- Error_Msg_N
- ("??pragma% is only effective in main program", N);
- end if;
- end Check_In_Main_Program;
+ elsif Chars (Mode) = Name_Output then
+ Check_Duplicate_Mode (Mode, Output_Seen);
+ Check_Mode_Restriction_In_Function (Mode);
- ---------------------------------------
- -- Check_Interrupt_Or_Attach_Handler --
- ---------------------------------------
+ else
+ Error_Msg_N ("invalid mode selector", Mode);
+ end if;
- procedure Check_Interrupt_Or_Attach_Handler is
- Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
- Handler_Proc, Proc_Scope : Entity_Id;
+ else
+ Error_Msg_N ("invalid mode selector", Mode);
+ end if;
- begin
- Analyze (Arg1_X);
+ -- Items in a moded list appear as a collection of
+ -- expressions. Reuse the existing machinery to analyze
+ -- them.
- if Prag_Id = Pragma_Interrupt_Handler then
- Check_Restriction (No_Dynamic_Attachment, N);
- end if;
+ Analyze_Global_List
+ (List => Expression (Assoc),
+ Global_Mode => Chars (Mode));
- Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
- Proc_Scope := Scope (Handler_Proc);
+ Next (Assoc);
+ end loop;
- -- On AAMP only, a pragma Interrupt_Handler is supported for
- -- nonprotected parameterless procedures.
+ -- Something went horribly wrong, we have a malformed tree
- if not AAMP_On_Target
- or else Prag_Id = Pragma_Attach_Handler
- then
- if Ekind (Proc_Scope) /= E_Protected_Type then
- Error_Pragma_Arg
- ("argument of pragma% must be protected procedure", Arg1);
+ else
+ raise Program_Error;
end if;
- if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
- Error_Pragma ("pragma% must be in protected definition");
- end if;
- end if;
+ -- Any other attempt to declare a global item is erroneous
- if not Is_Library_Level_Entity (Proc_Scope)
- or else (AAMP_On_Target
- and then not Is_Library_Level_Entity (Handler_Proc))
- then
- Error_Pragma_Arg
- ("argument for pragma% must be library level entity", Arg1);
+ else
+ Error_Msg_N ("malformed global list declaration", List);
end if;
+ end Analyze_Global_List;
- -- AI05-0033: A pragma cannot appear within a generic body, because
- -- instance can be in a nested scope. The check that protected type
- -- is itself a library-level declaration is done elsewhere.
+ -- Local variables
- -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
- -- handle code prior to AI-0033. Analysis tools typically are not
- -- interested in this pragma in any case, so no need to worry too
- -- much about its placement.
+ List : Node_Id;
+ Subp_Decl : Node_Id;
- if Inside_A_Generic then
- if Ekind (Scope (Current_Scope)) = E_Generic_Package
- and then In_Package_Body (Scope (Current_Scope))
- and then not Relaxed_RM_Semantics
- then
- Error_Pragma ("pragma% cannot be used inside a generic");
- end if;
- end if;
- end Check_Interrupt_Or_Attach_Handler;
+ -- Start of processing for Analyze_Global_In_Decl_List
- ---------------------------------
- -- Check_Loop_Pragma_Placement --
- ---------------------------------
+ begin
+ Set_Analyzed (N);
- procedure Check_Loop_Pragma_Placement is
- procedure Placement_Error (Constr : Node_Id);
- pragma No_Return (Placement_Error);
- -- Node Constr denotes the last loop restricted construct before we
- -- encountered an illegal relation between enclosing constructs. Emit
- -- an error depending on what Constr was.
+ Subp_Decl := Parent (Corresponding_Aspect (N));
+ Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
+ List := Expression (Arg1);
- ---------------------
- -- Placement_Error --
- ---------------------
+ -- There is nothing to be done for a null global list
- procedure Placement_Error (Constr : Node_Id) is
- begin
- if Nkind (Constr) = N_Pragma then
- Error_Pragma
- ("pragma % must appear immediately within the statements "
- & "of a loop");
- else
- Error_Pragma_Arg
- ("block containing pragma % must appear immediately within "
- & "the statements of a loop", Constr);
- end if;
- end Placement_Error;
+ if Nkind (List) = N_Null then
+ null;
- -- Local declarations
+ -- Analyze the various forms of global lists and items. Note that some
+ -- of these may be malformed in which case the analysis emits error
+ -- messages.
- Prev : Node_Id;
- Stmt : Node_Id;
+ elsif Nkind (Subp_Decl) = N_Subprogram_Body then
+ Analyze_Global_List (List);
- -- Start of processing for Check_Loop_Pragma_Placement
+ -- Ensure that the formal parameters are visible when processing an
+ -- item. This falls out of the general rule of aspects pertaining to
+ -- subprogram declarations.
- begin
- Prev := N;
- Stmt := Parent (N);
- while Present (Stmt) loop
+ else
+ Push_Scope (Subp_Id);
+ Install_Formals (Subp_Id);
- -- The pragma or previous block must appear immediately within the
- -- current block's declarative or statement part.
+ Analyze_Global_List (List);
- if Nkind (Stmt) = N_Block_Statement then
- if (No (Declarations (Stmt))
- or else List_Containing (Prev) /= Declarations (Stmt))
- and then
- List_Containing (Prev) /=
- Statements (Handled_Statement_Sequence (Stmt))
- then
- Placement_Error (Prev);
- return;
+ End_Scope;
+ end if;
+ end Analyze_Global_In_Decl_Part;
- -- Keep inspecting the parents because we are now within a
- -- chain of nested blocks.
+ ------------------------------
+ -- Analyze_PPC_In_Decl_Part --
+ ------------------------------
- else
- Prev := Stmt;
- Stmt := Parent (Stmt);
- end if;
+ procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
+ Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
- -- The pragma or previous block must appear immediately within the
- -- statements of the loop.
+ begin
+ -- Install formals and push subprogram spec onto scope stack so that we
+ -- can see the formals from the pragma.
- elsif Nkind (Stmt) = N_Loop_Statement then
- if List_Containing (Prev) /= Statements (Stmt) then
- Placement_Error (Prev);
- end if;
+ Install_Formals (S);
+ Push_Scope (S);
- -- Stop the traversal because we reached the innermost loop
- -- regardless of whether we encountered an error or not.
+ -- Preanalyze the boolean expression, we treat this as a spec expression
+ -- (i.e. similar to a default expression).
- return;
+ Preanalyze_Assert_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean);
- -- Ignore a handled statement sequence. Note that this node may
- -- be related to a subprogram body in which case we will emit an
- -- error on the next iteration of the search.
+ -- In ASIS mode, for a pragma generated from a source aspect, also
+ -- analyze the original aspect expression.
- elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
- Stmt := Parent (Stmt);
+ if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
+ Preanalyze_Assert_Expression
+ (Expression (Corresponding_Aspect (N)), Standard_Boolean);
+ end if;
- -- Any other statement breaks the chain from the pragma to the
- -- loop.
+ -- For a class-wide condition, a reference to a controlling formal must
+ -- be interpreted as having the class-wide type (or an access to such)
+ -- so that the inherited condition can be properly applied to any
+ -- overriding operation (see ARM12 6.6.1 (7)).
- else
- Placement_Error (Prev);
- return;
- end if;
- end loop;
- end Check_Loop_Pragma_Placement;
+ if Class_Present (N) then
+ Class_Wide_Condition : declare
+ T : constant Entity_Id := Find_Dispatching_Type (S);
- -------------------------------------------
- -- Check_Is_In_Decl_Part_Or_Package_Spec --
- -------------------------------------------
+ ACW : Entity_Id := Empty;
+ -- Access to T'class, created if there is a controlling formal
+ -- that is an access parameter.
- procedure Check_Is_In_Decl_Part_Or_Package_Spec is
- P : Node_Id;
+ function Get_ACW return Entity_Id;
+ -- If the expression has a reference to an controlling access
+ -- parameter, create an access to T'class for the necessary
+ -- conversions if one does not exist.
- begin
- P := Parent (N);
- loop
- if No (P) then
- exit;
+ function Process (N : Node_Id) return Traverse_Result;
+ -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
+ -- aspect for a primitive subprogram of a tagged type T, a name
+ -- that denotes a formal parameter of type T is interpreted as
+ -- having type T'Class. Similarly, a name that denotes a formal
+ -- accessparameter of type access-to-T is interpreted as having
+ -- type access-to-T'Class. This ensures the expression is well-
+ -- defined for a primitive subprogram of a type descended from T.
- elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
- exit;
+ -------------
+ -- Get_ACW --
+ -------------
- elsif Nkind_In (P, N_Package_Specification,
- N_Block_Statement)
- then
- return;
+ function Get_ACW return Entity_Id is
+ Loc : constant Source_Ptr := Sloc (N);
+ Decl : Node_Id;
- -- Note: the following tests seem a little peculiar, because
- -- they test for bodies, but if we were in the statement part
- -- of the body, we would already have hit the handled statement
- -- sequence, so the only way we get here is by being in the
- -- declarative part of the body.
+ begin
+ if No (ACW) then
+ Decl := Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'T'),
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (Class_Wide_Type (T), Loc),
+ All_Present => True));
- elsif Nkind_In (P, N_Subprogram_Body,
- N_Package_Body,
- N_Task_Body,
- N_Entry_Body)
- then
- return;
- end if;
+ Insert_Before (Unit_Declaration_Node (S), Decl);
+ Analyze (Decl);
+ ACW := Defining_Identifier (Decl);
+ Freeze_Before (Unit_Declaration_Node (S), ACW);
+ end if;
- P := Parent (P);
- end loop;
+ return ACW;
+ end Get_ACW;
- Error_Pragma ("pragma% is not in declarative part or package spec");
- end Check_Is_In_Decl_Part_Or_Package_Spec;
+ -------------
+ -- Process --
+ -------------
- -------------------------
- -- Check_No_Identifier --
- -------------------------
+ function Process (N : Node_Id) return Traverse_Result is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : Entity_Id;
- procedure Check_No_Identifier (Arg : Node_Id) is
- begin
- if Nkind (Arg) = N_Pragma_Argument_Association
- and then Chars (Arg) /= No_Name
- then
- Error_Pragma_Arg_Ident
- ("pragma% does not permit identifier& here", Arg);
- end if;
- end Check_No_Identifier;
+ begin
+ if Is_Entity_Name (N)
+ and then Is_Formal (Entity (N))
+ and then Nkind (Parent (N)) /= N_Type_Conversion
+ then
+ if Etype (Entity (N)) = T then
+ Typ := Class_Wide_Type (T);
- --------------------------
- -- Check_No_Identifiers --
- --------------------------
+ elsif Is_Access_Type (Etype (Entity (N)))
+ and then Designated_Type (Etype (Entity (N))) = T
+ then
+ Typ := Get_ACW;
+ else
+ Typ := Empty;
+ end if;
- procedure Check_No_Identifiers is
- Arg_Node : Node_Id;
- begin
- if Arg_Count > 0 then
- Arg_Node := Arg1;
- while Present (Arg_Node) loop
- Check_No_Identifier (Arg_Node);
- Next (Arg_Node);
- end loop;
- end if;
- end Check_No_Identifiers;
+ if Present (Typ) then
+ Rewrite (N,
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Typ, Loc),
+ Expression => New_Occurrence_Of (Entity (N), Loc)));
+ Set_Etype (N, Typ);
+ end if;
+ end if;
- ------------------------
- -- Check_No_Link_Name --
- ------------------------
+ return OK;
+ end Process;
- procedure Check_No_Link_Name is
- begin
- if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
- Arg4 := Arg3;
- end if;
+ procedure Replace_Type is new Traverse_Proc (Process);
- if Present (Arg4) then
- Error_Pragma_Arg
- ("Link_Name argument not allowed for Import Intrinsic", Arg4);
- end if;
- end Check_No_Link_Name;
+ -- Start of processing for Class_Wide_Condition
- -------------------------------
- -- Check_Optional_Identifier --
- -------------------------------
+ begin
+ if not Present (T) then
+ Error_Msg_Name_1 :=
+ Chars (Identifier (Corresponding_Aspect (N)));
- procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
- begin
- if Present (Arg)
- and then Nkind (Arg) = N_Pragma_Argument_Association
- and then Chars (Arg) /= No_Name
- then
- if Chars (Arg) /= Id then
- Error_Msg_Name_1 := Pname;
- Error_Msg_Name_2 := Id;
- Error_Msg_N ("pragma% argument expects identifier%", Arg);
- raise Pragma_Exit;
+ Error_Msg_Name_2 := Name_Class;
+
+ Error_Msg_N
+ ("aspect `%''%` can only be specified for a primitive "
+ & "operation of a tagged type", Corresponding_Aspect (N));
end if;
- end if;
- end Check_Optional_Identifier;
- procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
- begin
- Name_Buffer (1 .. Id'Length) := Id;
- Name_Len := Id'Length;
- Check_Optional_Identifier (Arg, Name_Find);
- end Check_Optional_Identifier;
+ Replace_Type (Get_Pragma_Arg (Arg1));
+ end Class_Wide_Condition;
+ end if;
- --------------------------------------
- -- Check_Precondition_Postcondition --
- --------------------------------------
+ -- Remove the subprogram from the scope stack now that the pre-analysis
+ -- of the precondition/postcondition is done.
- procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
- P : Node_Id;
- PO : Node_Id;
+ End_Scope;
+ end Analyze_PPC_In_Decl_Part;
- procedure Chain_PPC (PO : Node_Id);
- -- If PO is an entry or a [generic] subprogram declaration node, then
- -- the precondition/postcondition applies to this subprogram and the
- -- processing for the pragma is completed. Otherwise the pragma is
- -- misplaced.
+ --------------------
+ -- Analyze_Pragma --
+ --------------------
- ---------------
- -- Chain_PPC --
- ---------------
+ procedure Analyze_Pragma (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Prag_Id : Pragma_Id;
- procedure Chain_PPC (PO : Node_Id) is
- S : Entity_Id;
+ Pname : Name_Id;
+ -- Name of the source pragma, or name of the corresponding aspect for
+ -- pragmas which originate in a source aspect. In the latter case, the
+ -- name may be different from the pragma name.
- begin
- if Nkind (PO) = N_Abstract_Subprogram_Declaration then
- if not From_Aspect_Specification (N) then
- Error_Pragma
- ("pragma% cannot be applied to abstract subprogram");
+ Pragma_Exit : exception;
+ -- This exception is used to exit pragma processing completely. It is
+ -- used when an error is detected, and no further processing is
+ -- required. It is also used if an earlier error has left the tree in
+ -- a state where the pragma should not be processed.
- elsif Class_Present (N) then
- null;
+ Arg_Count : Nat;
+ -- Number of pragma argument associations
- else
- Error_Pragma
- ("aspect % requires ''Class for abstract subprogram");
- end if;
+ Arg1 : Node_Id;
+ Arg2 : Node_Id;
+ Arg3 : Node_Id;
+ Arg4 : Node_Id;
+ -- First four pragma arguments (pragma argument association nodes, or
+ -- Empty if the corresponding argument does not exist).
- -- AI05-0230: The same restriction applies to null procedures. For
- -- compatibility with earlier uses of the Ada pragma, apply this
- -- rule only to aspect specifications.
+ type Name_List is array (Natural range <>) of Name_Id;
+ type Args_List is array (Natural range <>) of Node_Id;
+ -- Types used for arguments to Check_Arg_Order and Gather_Associations
- -- The above discrpency needs documentation. Robert is dubious
- -- about whether it is a good idea ???
+ procedure Ada_2005_Pragma;
+ -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
+ -- Ada 95 mode, these are implementation defined pragmas, so should be
+ -- caught by the No_Implementation_Pragmas restriction.
- elsif Nkind (PO) = N_Subprogram_Declaration
- and then Nkind (Specification (PO)) = N_Procedure_Specification
- and then Null_Present (Specification (PO))
- and then From_Aspect_Specification (N)
- and then not Class_Present (N)
- then
- Error_Pragma
- ("aspect % requires ''Class for null procedure");
+ procedure Ada_2012_Pragma;
+ -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
+ -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
+ -- should be caught by the No_Implementation_Pragmas restriction.
- -- Pre/postconditions are legal on a subprogram body if it is not
- -- a completion of a declaration. They are also legal on a stub
- -- with no previous declarations (this is checked when processing
- -- the corresponding aspects).
-
- elsif Nkind (PO) = N_Subprogram_Body
- and then Acts_As_Spec (PO)
- then
- null;
-
- elsif Nkind (PO) = N_Subprogram_Body_Stub then
- null;
+ procedure Check_Ada_83_Warning;
+ -- Issues a warning message for the current pragma if operating in Ada
+ -- 83 mode (used for language pragmas that are not a standard part of
+ -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
+ -- of 95 pragma.
- elsif not Nkind_In (PO, N_Subprogram_Declaration,
- N_Expression_Function,
- N_Generic_Subprogram_Declaration,
- N_Entry_Declaration)
- then
- Pragma_Misplaced;
- end if;
+ procedure Check_Arg_Count (Required : Nat);
+ -- Check argument count for pragma is equal to given parameter. If not,
+ -- then issue an error message and raise Pragma_Exit.
- -- Here if we have [generic] subprogram or entry declaration
+ -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
+ -- Arg which can either be a pragma argument association, in which case
+ -- the check is applied to the expression of the association or an
+ -- expression directly.
- if Nkind (PO) = N_Entry_Declaration then
- S := Defining_Entity (PO);
- else
- S := Defining_Unit_Name (Specification (PO));
+ procedure Check_Arg_Is_External_Name (Arg : Node_Id);
+ -- Check that an argument has the right form for an EXTERNAL_NAME
+ -- parameter of an extended import/export pragma. The rule is that the
+ -- name must be an identifier or string literal (in Ada 83 mode) or a
+ -- static string expression (in Ada 95 mode).
- if Nkind (S) = N_Defining_Program_Unit_Name then
- S := Defining_Identifier (S);
- end if;
- end if;
+ procedure Check_Arg_Is_Identifier (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it is an
+ -- identifier. If not give error and raise Pragma_Exit.
- -- Note: we do not analyze the pragma at this point. Instead we
- -- delay this analysis until the end of the declarative part in
- -- which the pragma appears. This implements the required delay
- -- in this analysis, allowing forward references. The analysis
- -- happens at the end of Analyze_Declarations.
+ procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it is an integer
+ -- literal. If not give error and raise Pragma_Exit.
- -- Chain spec PPC pragma to list for subprogram
+ procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it has the proper
+ -- syntactic form for a local name and meets the semantic requirements
+ -- for a local name. The local name is analyzed as part of the
+ -- processing for this call. In addition, the local name is required
+ -- to represent an entity at the library level.
- Set_Next_Pragma (N, Spec_PPC_List (Contract (S)));
- Set_Spec_PPC_List (Contract (S), N);
+ procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it has the proper
+ -- syntactic form for a local name and meets the semantic requirements
+ -- for a local name. The local name is analyzed as part of the
+ -- processing for this call.
- -- Return indicating spec case
+ procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it is a valid
+ -- locking policy name. If not give error and raise Pragma_Exit.
- In_Body := False;
- return;
- end Chain_PPC;
+ procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it is a valid
+ -- elaboration policy name. If not give error and raise Pragma_Exit.
- -- Start of processing for Check_Precondition_Postcondition
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
+ N1, N2 : Name_Id);
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
+ N1, N2, N3 : Name_Id);
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
+ N1, N2, N3, N4 : Name_Id);
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
+ N1, N2, N3, N4, N5 : Name_Id);
+ -- Check the specified argument Arg to make sure that it is an
+ -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
+ -- present). If not then give error and raise Pragma_Exit.
- begin
- if not Is_List_Member (N) then
- Pragma_Misplaced;
- end if;
+ procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it is a valid
+ -- queuing policy name. If not give error and raise Pragma_Exit.
- -- Preanalyze message argument if present. Visibility in this
- -- argument is established at the point of pragma occurrence.
+ procedure Check_Arg_Is_Static_Expression
+ (Arg : Node_Id;
+ Typ : Entity_Id := Empty);
+ -- Check the specified argument Arg to make sure that it is a static
+ -- expression of the given type (i.e. it will be analyzed and resolved
+ -- using this type, which can be any valid argument to Resolve, e.g.
+ -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
+ -- Typ is left Empty, then any static expression is allowed.
- if Arg_Count = 2 then
- Check_Optional_Identifier (Arg2, Name_Message);
- Preanalyze_Spec_Expression
- (Get_Pragma_Arg (Arg2), Standard_String);
- end if;
+ procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
+ -- Check the specified argument Arg to make sure that it is a valid task
+ -- dispatching policy name. If not give error and raise Pragma_Exit.
- -- For a pragma PPC in the extended main source unit, record enabled
- -- status in SCO.
+ procedure Check_Arg_Order (Names : Name_List);
+ -- Checks for an instance of two arguments with identifiers for the
+ -- current pragma which are not in the sequence indicated by Names,
+ -- and if so, generates a fatal message about bad order of arguments.
- if not Is_Ignored (N) and then not Split_PPC (N) then
- Set_SCO_Pragma_Enabled (Loc);
- end if;
+ procedure Check_At_Least_N_Arguments (N : Nat);
+ -- Check there are at least N arguments present
- -- If we are within an inlined body, the legality of the pragma
- -- has been checked already.
+ procedure Check_At_Most_N_Arguments (N : Nat);
+ -- Check there are no more than N arguments present
- if In_Inlined_Body then
- In_Body := True;
- return;
- end if;
+ procedure Check_Component
+ (Comp : Node_Id;
+ UU_Typ : Entity_Id;
+ In_Variant_Part : Boolean := False);
+ -- Examine an Unchecked_Union component for correct use of per-object
+ -- constrained subtypes, and for restrictions on finalizable components.
+ -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
+ -- should be set when Comp comes from a record variant.
- -- Search prior declarations
+ procedure Check_Test_Case;
+ -- Called to process a test-case pragma. It starts with checking pragma
+ -- arguments, and the rest of the treatment is similar to the one for
+ -- pre- and postcondition in Check_Precondition_Postcondition, except
+ -- the placement rules for the test-case pragma are stricter. These
+ -- pragmas may only occur after a subprogram spec declared directly
+ -- in a package spec unit. In this case, the pragma is chained to the
+ -- subprogram in question (using Contract_Test_Cases and Next_Pragma)
+ -- and analysis of the pragma is delayed till the end of the spec. In
+ -- all other cases, an error message for bad placement is given.
- P := N;
- while Present (Prev (P)) loop
- P := Prev (P);
+ procedure Check_Duplicate_Pragma (E : Entity_Id);
+ -- Check if a rep item of the same name as the current pragma is already
+ -- chained as a rep pragma to the given entity. If so give a message
+ -- about the duplicate, and then raise Pragma_Exit so does not return.
- -- If the previous node is a generic subprogram, do not go to to
- -- the original node, which is the unanalyzed tree: we need to
- -- attach the pre/postconditions to the analyzed version at this
- -- point. They get propagated to the original tree when analyzing
- -- the corresponding body.
+ procedure Check_Duplicated_Export_Name (Nam : Node_Id);
+ -- Nam is an N_String_Literal node containing the external name set by
+ -- an Import or Export pragma (or extended Import or Export pragma).
+ -- This procedure checks for possible duplications if this is the export
+ -- case, and if found, issues an appropriate error message.
- if Nkind (P) not in N_Generic_Declaration then
- PO := Original_Node (P);
- else
- PO := P;
- end if;
+ procedure Check_Expr_Is_Static_Expression
+ (Expr : Node_Id;
+ Typ : Entity_Id := Empty);
+ -- Check the specified expression Expr to make sure that it is a static
+ -- expression of the given type (i.e. it will be analyzed and resolved
+ -- using this type, which can be any valid argument to Resolve, e.g.
+ -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
+ -- Typ is left Empty, then any static expression is allowed.
- -- Skip past prior pragma
+ procedure Check_First_Subtype (Arg : Node_Id);
+ -- Checks that Arg, whose expression is an entity name, references a
+ -- first subtype.
- if Nkind (PO) = N_Pragma then
- null;
+ procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
+ -- Checks that the given argument has an identifier, and if so, requires
+ -- it to match the given identifier name. If there is no identifier, or
+ -- a non-matching identifier, then an error message is given and
+ -- Pragma_Exit is raised.
- -- Skip stuff not coming from source
+ procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
+ -- Checks that the given argument has an identifier, and if so, requires
+ -- it to match one of the given identifier names. If there is no
+ -- identifier, or a non-matching identifier, then an error message is
+ -- given and Pragma_Exit is raised.
- elsif not Comes_From_Source (PO) then
+ procedure Check_In_Main_Program;
+ -- Common checks for pragmas that appear within a main program
+ -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
- -- The condition may apply to a subprogram instantiation
+ procedure Check_Interrupt_Or_Attach_Handler;
+ -- Common processing for first argument of pragma Interrupt_Handler or
+ -- pragma Attach_Handler.
- if Nkind (PO) = N_Subprogram_Declaration
- and then Present (Generic_Parent (Specification (PO)))
- then
- Chain_PPC (PO);
- return;
+ procedure Check_Loop_Pragma_Placement;
+ -- Verify whether pragma Loop_Invariant or Loop_Optimize or Loop_Variant
+ -- appear immediately within a construct restricted to loops.
- elsif Nkind (PO) = N_Subprogram_Declaration
- and then In_Instance
- then
- Chain_PPC (PO);
- return;
+ procedure Check_Is_In_Decl_Part_Or_Package_Spec;
+ -- Check that pragma appears in a declarative part, or in a package
+ -- specification, i.e. that it does not occur in a statement sequence
+ -- in a body.
- -- For all other cases of non source code, do nothing
+ procedure Check_No_Identifier (Arg : Node_Id);
+ -- Checks that the given argument does not have an identifier. If
+ -- an identifier is present, then an error message is issued, and
+ -- Pragma_Exit is raised.
- else
- null;
- end if;
+ procedure Check_No_Identifiers;
+ -- Checks that none of the arguments to the pragma has an identifier.
+ -- If any argument has an identifier, then an error message is issued,
+ -- and Pragma_Exit is raised.
- -- Only remaining possibility is subprogram declaration
+ procedure Check_No_Link_Name;
+ -- Checks that no link name is specified
- else
- Chain_PPC (PO);
- return;
- end if;
- end loop;
+ procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
+ -- Checks if the given argument has an identifier, and if so, requires
+ -- it to match the given identifier name. If there is a non-matching
+ -- identifier, then an error message is given and Pragma_Exit is raised.
- -- If we fall through loop, pragma is at start of list, so see if it
- -- is at the start of declarations of a subprogram body.
+ procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
+ -- Checks if the given argument has an identifier, and if so, requires
+ -- it to match the given identifier name. If there is a non-matching
+ -- identifier, then an error message is given and Pragma_Exit is raised.
+ -- In this version of the procedure, the identifier name is given as
+ -- a string with lower case letters.
- if Nkind (Parent (N)) = N_Subprogram_Body
- and then List_Containing (N) = Declarations (Parent (N))
- then
- if Operating_Mode /= Generate_Code
- or else Inside_A_Generic
- then
- -- Analyze pragma expression for correctness and for ASIS use
+ procedure Check_Precondition_Postcondition (In_Body : out Boolean);
+ -- Called to process a precondition or postcondition pragma. There are
+ -- three cases:
+ --
+ -- The pragma appears after a subprogram spec
+ --
+ -- If the corresponding check is not enabled, the pragma is analyzed
+ -- but otherwise ignored and control returns with In_Body set False.
+ --
+ -- If the check is enabled, then the first step is to analyze the
+ -- pragma, but this is skipped if the subprogram spec appears within
+ -- a package specification (because this is the case where we delay
+ -- analysis till the end of the spec). Then (whether or not it was
+ -- analyzed), the pragma is chained to the subprogram in question
+ -- (using Pre_Post_Conditions and Next_Pragma) and control returns
+ -- to the caller with In_Body set False.
+ --
+ -- The pragma appears at the start of subprogram body declarations
+ --
+ -- In this case an immediate return to the caller is made with
+ -- In_Body set True, and the pragma is NOT analyzed.
+ --
+ -- In all other cases, an error message for bad placement is given
- Preanalyze_Assert_Expression
- (Get_Pragma_Arg (Arg1), Standard_Boolean);
+ procedure Check_Static_Constraint (Constr : Node_Id);
+ -- Constr is a constraint from an N_Subtype_Indication node from a
+ -- component constraint in an Unchecked_Union type. This routine checks
+ -- that the constraint is static as required by the restrictions for
+ -- Unchecked_Union.
- -- In ASIS mode, for a pragma generated from a source aspect,
- -- also analyze the original aspect expression.
+ procedure Check_Valid_Configuration_Pragma;
+ -- Legality checks for placement of a configuration pragma
- if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
- Preanalyze_Assert_Expression
- (Expression (Corresponding_Aspect (N)), Standard_Boolean);
- end if;
- end if;
+ procedure Check_Valid_Library_Unit_Pragma;
+ -- Legality checks for library unit pragmas. A special case arises for
+ -- pragmas in generic instances that come from copies of the original
+ -- library unit pragmas in the generic templates. In the case of other
+ -- than library level instantiations these can appear in contexts which
+ -- would normally be invalid (they only apply to the original template
+ -- and to library level instantiations), and they are simply ignored,
+ -- which is implemented by rewriting them as null statements.
- In_Body := True;
- return;
+ procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
+ -- Check an Unchecked_Union variant for lack of nested variants and
+ -- presence of at least one component. UU_Typ is the related Unchecked_
+ -- Union type.
- -- See if it is in the pragmas after a library level subprogram
+ procedure Error_Pragma (Msg : String);
+ pragma No_Return (Error_Pragma);
+ -- Outputs error message for current pragma. The message contains a %
+ -- that will be replaced with the pragma name, and the flag is placed
+ -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
+ -- calls Fix_Error (see spec of that procedure for details).
- elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then
+ procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
+ pragma No_Return (Error_Pragma_Arg);
+ -- Outputs error message for current pragma. The message may contain
+ -- a % that will be replaced with the pragma name. The parameter Arg
+ -- may either be a pragma argument association, in which case the flag
+ -- is placed on the expression of this association, or an expression,
+ -- in which case the flag is placed directly on the expression. The
+ -- message is placed using Error_Msg_N, so the message may also contain
+ -- an & insertion character which will reference the given Arg value.
+ -- After placing the message, Pragma_Exit is raised. Note: this routine
+ -- calls Fix_Error (see spec of that procedure for details).
- -- In formal verification mode, analyze pragma expression for
- -- correctness, as it is not expanded later.
+ procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
+ pragma No_Return (Error_Pragma_Arg);
+ -- Similar to above form of Error_Pragma_Arg except that two messages
+ -- are provided, the second is a continuation comment starting with \.
- if Alfa_Mode then
- Analyze_PPC_In_Decl_Part
- (N, Defining_Entity (Unit (Parent (Parent (N)))));
- end if;
+ procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
+ pragma No_Return (Error_Pragma_Arg_Ident);
+ -- Outputs error message for current pragma. The message may contain
+ -- a % that will be replaced with the pragma name. The parameter Arg
+ -- must be a pragma argument association with a non-empty identifier
+ -- (i.e. its Chars field must be set), and the error message is placed
+ -- on the identifier. The message is placed using Error_Msg_N so
+ -- the message may also contain an & insertion character which will
+ -- reference the identifier. After placing the message, Pragma_Exit
+ -- is raised. Note: this routine calls Fix_Error (see spec of that
+ -- procedure for details).
- Chain_PPC (Unit (Parent (Parent (N))));
- return;
- end if;
+ procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
+ pragma No_Return (Error_Pragma_Ref);
+ -- Outputs error message for current pragma. The message may contain
+ -- a % that will be replaced with the pragma name. The parameter Ref
+ -- must be an entity whose name can be referenced by & and sloc by #.
+ -- After placing the message, Pragma_Exit is raised. Note: this routine
+ -- calls Fix_Error (see spec of that procedure for details).
- -- If we fall through, pragma was misplaced
+ function Find_Lib_Unit_Name return Entity_Id;
+ -- Used for a library unit pragma to find the entity to which the
+ -- library unit pragma applies, returns the entity found.
- Pragma_Misplaced;
- end Check_Precondition_Postcondition;
+ procedure Find_Program_Unit_Name (Id : Node_Id);
+ -- If the pragma is a compilation unit pragma, the id must denote the
+ -- compilation unit in the same compilation, and the pragma must appear
+ -- in the list of preceding or trailing pragmas. If it is a program
+ -- unit pragma that is not a compilation unit pragma, then the
+ -- identifier must be visible.
- -----------------------------
- -- Check_Static_Constraint --
- -----------------------------
+ function Find_Unique_Parameterless_Procedure
+ (Name : Entity_Id;
+ Arg : Node_Id) return Entity_Id;
+ -- Used for a procedure pragma to find the unique parameterless
+ -- procedure identified by Name, returns it if it exists, otherwise
+ -- errors out and uses Arg as the pragma argument for the message.
- -- Note: for convenience in writing this procedure, in addition to
- -- the officially (i.e. by spec) allowed argument which is always a
- -- constraint, it also allows ranges and discriminant associations.
- -- Above is not clear ???
+ procedure Fix_Error (Msg : in out String);
+ -- This is called prior to issuing an error message. Msg is a string
+ -- that typically contains the substring "pragma". If the pragma comes
+ -- from an aspect, each such "pragma" substring is replaced with the
+ -- characters "aspect", and Error_Msg_Name_1 is set to the name of the
+ -- aspect (which may be different from the pragma name). If the current
+ -- pragma results from rewriting another pragma, then Error_Msg_Name_1
+ -- is set to the original pragma name.
- procedure Check_Static_Constraint (Constr : Node_Id) is
+ procedure Gather_Associations
+ (Names : Name_List;
+ Args : out Args_List);
+ -- This procedure is used to gather the arguments for a pragma that
+ -- permits arbitrary ordering of parameters using the normal rules
+ -- for named and positional parameters. The Names argument is a list
+ -- of Name_Id values that corresponds to the allowed pragma argument
+ -- association identifiers in order. The result returned in Args is
+ -- a list of corresponding expressions that are the pragma arguments.
+ -- Note that this is a list of expressions, not of pragma argument
+ -- associations (Gather_Associations has completely checked all the
+ -- optional identifiers when it returns). An entry in Args is Empty
+ -- on return if the corresponding argument is not present.
- procedure Require_Static (E : Node_Id);
- -- Require given expression to be static expression
+ procedure GNAT_Pragma;
+ -- Called for all GNAT defined pragmas to check the relevant restriction
+ -- (No_Implementation_Pragmas).
- --------------------
- -- Require_Static --
- --------------------
+ procedure S14_Pragma;
+ -- Called for all pragmas defined for formal verification to check that
+ -- the S14_Extensions flag is set.
+ -- This name needs fixing ??? There is no such thing as an
+ -- "S14_Extensions" flag ???
- procedure Require_Static (E : Node_Id) is
- begin
- if not Is_OK_Static_Expression (E) then
- Flag_Non_Static_Expr
- ("non-static constraint not allowed in Unchecked_Union!", E);
- raise Pragma_Exit;
- end if;
- end Require_Static;
+ function Is_Before_First_Decl
+ (Pragma_Node : Node_Id;
+ Decls : List_Id) return Boolean;
+ -- Return True if Pragma_Node is before the first declarative item in
+ -- Decls where Decls is the list of declarative items.
- -- Start of processing for Check_Static_Constraint
+ function Is_Configuration_Pragma return Boolean;
+ -- Determines if the placement of the current pragma is appropriate
+ -- for a configuration pragma.
- begin
- case Nkind (Constr) is
- when N_Discriminant_Association =>
- Require_Static (Expression (Constr));
+ function Is_In_Context_Clause return Boolean;
+ -- Returns True if pragma appears within the context clause of a unit,
+ -- and False for any other placement (does not generate any messages).
- when N_Range =>
- Require_Static (Low_Bound (Constr));
- Require_Static (High_Bound (Constr));
+ function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
+ -- Analyzes the argument, and determines if it is a static string
+ -- expression, returns True if so, False if non-static or not String.
- when N_Attribute_Reference =>
- Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
- Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
+ procedure Pragma_Misplaced;
+ pragma No_Return (Pragma_Misplaced);
+ -- Issue fatal error message for misplaced pragma
- when N_Range_Constraint =>
- Check_Static_Constraint (Range_Expression (Constr));
+ procedure Process_Atomic_Shared_Volatile;
+ -- Common processing for pragmas Atomic, Shared, Volatile. Note that
+ -- Shared is an obsolete Ada 83 pragma, treated as being identical
+ -- in effect to pragma Atomic.
- when N_Index_Or_Discriminant_Constraint =>
- declare
- IDC : Entity_Id;
- begin
- IDC := First (Constraints (Constr));
- while Present (IDC) loop
- Check_Static_Constraint (IDC);
- Next (IDC);
- end loop;
- end;
+ procedure Process_Compile_Time_Warning_Or_Error;
+ -- Common processing for Compile_Time_Error and Compile_Time_Warning
- when others =>
- null;
- end case;
- end Check_Static_Constraint;
+ procedure Process_Convention
+ (C : out Convention_Id;
+ Ent : out Entity_Id);
+ -- Common processing for Convention, Interface, Import and Export.
+ -- Checks first two arguments of pragma, and sets the appropriate
+ -- convention value in the specified entity or entities. On return
+ -- C is the convention, Ent is the referenced entity.
- ---------------------
- -- Check_Test_Case --
- ---------------------
+ procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
+ -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
+ -- Name_Suppress for Disable and Name_Unsuppress for Enable.
- procedure Check_Test_Case is
- P : Node_Id;
- PO : Node_Id;
+ procedure Process_Extended_Import_Export_Exception_Pragma
+ (Arg_Internal : Node_Id;
+ Arg_External : Node_Id;
+ Arg_Form : Node_Id;
+ Arg_Code : Node_Id);
+ -- Common processing for the pragmas Import/Export_Exception. The three
+ -- arguments correspond to the three named parameters of the pragma. An
+ -- argument is empty if the corresponding parameter is not present in
+ -- the pragma.
- procedure Chain_CTC (PO : Node_Id);
- -- If PO is a [generic] subprogram declaration node, then the
- -- test-case applies to this subprogram and the processing for
- -- the pragma is completed. Otherwise the pragma is misplaced.
+ procedure Process_Extended_Import_Export_Object_Pragma
+ (Arg_Internal : Node_Id;
+ Arg_External : Node_Id;
+ Arg_Size : Node_Id);
+ -- Common processing for the pragmas Import/Export_Object. The three
+ -- arguments correspond to the three named parameters of the pragmas. An
+ -- argument is empty if the corresponding parameter is not present in
+ -- the pragma.
- ---------------
- -- Chain_CTC --
- ---------------
+ procedure Process_Extended_Import_Export_Internal_Arg
+ (Arg_Internal : Node_Id := Empty);
+ -- Common processing for all extended Import and Export pragmas. The
+ -- argument is the pragma parameter for the Internal argument. If
+ -- Arg_Internal is empty or inappropriate, an error message is posted.
+ -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
+ -- set to identify the referenced entity.
- procedure Chain_CTC (PO : Node_Id) is
- S : Entity_Id;
+ procedure Process_Extended_Import_Export_Subprogram_Pragma
+ (Arg_Internal : Node_Id;
+ Arg_External : Node_Id;
+ Arg_Parameter_Types : Node_Id;
+ Arg_Result_Type : Node_Id := Empty;
+ Arg_Mechanism : Node_Id;
+ Arg_Result_Mechanism : Node_Id := Empty;
+ Arg_First_Optional_Parameter : Node_Id := Empty);
+ -- Common processing for all extended Import and Export pragmas applying
+ -- to subprograms. The caller omits any arguments that do not apply to
+ -- the pragma in question (for example, Arg_Result_Type can be non-Empty
+ -- only in the Import_Function and Export_Function cases). The argument
+ -- names correspond to the allowed pragma association identifiers.
+
+ procedure Process_Generic_List;
+ -- Common processing for Share_Generic and Inline_Generic
+
+ procedure Process_Import_Or_Interface;
+ -- Common processing for Import of Interface
- begin
- if Nkind (PO) = N_Abstract_Subprogram_Declaration then
- Error_Pragma
- ("pragma% cannot be applied to abstract subprogram");
+ procedure Process_Import_Predefined_Type;
+ -- Processing for completing a type with pragma Import. This is used
+ -- to declare types that match predefined C types, especially for cases
+ -- without corresponding Ada predefined type.
- elsif Nkind (PO) = N_Entry_Declaration then
- Error_Pragma ("pragma% cannot be applied to entry");
+ type Inline_Status is (Suppressed, Disabled, Enabled);
+ -- Inline status of a subprogram, indicated as follows:
+ -- Suppressed: inlining is suppressed for the subprogram
+ -- Disabled: no inlining is requested for the subprogram
+ -- Enabled: inlining is requested/required for the subprogram
- elsif not Nkind_In (PO, N_Subprogram_Declaration,
- N_Generic_Subprogram_Declaration)
- then
- Pragma_Misplaced;
- end if;
+ procedure Process_Inline (Status : Inline_Status);
+ -- Common processing for Inline, Inline_Always and No_Inline. Parameter
+ -- indicates the inline status specified by the pragma.
- -- Here if we have [generic] subprogram declaration
+ procedure Process_Interface_Name
+ (Subprogram_Def : Entity_Id;
+ Ext_Arg : Node_Id;
+ Link_Arg : Node_Id);
+ -- Given the last two arguments of pragma Import, pragma Export, or
+ -- pragma Interface_Name, performs validity checks and sets the
+ -- Interface_Name field of the given subprogram entity to the
+ -- appropriate external or link name, depending on the arguments given.
+ -- Ext_Arg is always present, but Link_Arg may be missing. Note that
+ -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
+ -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
+ -- nor Link_Arg is present, the interface name is set to the default
+ -- from the subprogram name.
- S := Defining_Unit_Name (Specification (PO));
+ procedure Process_Interrupt_Or_Attach_Handler;
+ -- Common processing for Interrupt and Attach_Handler pragmas
- -- Note: we do not analyze the pragma at this point. Instead we
- -- delay this analysis until the end of the declarative part in
- -- which the pragma appears. This implements the required delay
- -- in this analysis, allowing forward references. The analysis
- -- happens at the end of Analyze_Declarations.
+ procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
+ -- Common processing for Restrictions and Restriction_Warnings pragmas.
+ -- Warn is True for Restriction_Warnings, or for Restrictions if the
+ -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
+ -- is not set in the Restrictions case.
- -- There should not be another test-case with the same name
- -- associated to this subprogram.
+ procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
+ -- Common processing for Suppress and Unsuppress. The boolean parameter
+ -- Suppress_Case is True for the Suppress case, and False for the
+ -- Unsuppress case.
- declare
- Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
- CTC : Node_Id;
+ procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
+ -- This procedure sets the Is_Exported flag for the given entity,
+ -- checking that the entity was not previously imported. Arg is
+ -- the argument that specified the entity. A check is also made
+ -- for exporting inappropriate entities.
- begin
- CTC := Spec_CTC_List (Contract (S));
- while Present (CTC) loop
+ procedure Set_Extended_Import_Export_External_Name
+ (Internal_Ent : Entity_Id;
+ Arg_External : Node_Id);
+ -- Common processing for all extended import export pragmas. The first
+ -- argument, Internal_Ent, is the internal entity, which has already
+ -- been checked for validity by the caller. Arg_External is from the
+ -- Import or Export pragma, and may be null if no External parameter
+ -- was present. If Arg_External is present and is a non-null string
+ -- (a null string is treated as the default), then the Interface_Name
+ -- field of Internal_Ent is set appropriately.
- -- Omit pragma Contract_Cases because it does not introduce
- -- a unique case name and it does not follow the syntax of
- -- Test_Case.
+ procedure Set_Imported (E : Entity_Id);
+ -- This procedure sets the Is_Imported flag for the given entity,
+ -- checking that it is not previously exported or imported.
- if Pragma_Name (CTC) = Name_Contract_Cases then
- null;
+ procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
+ -- Mech is a parameter passing mechanism (see Import_Function syntax
+ -- for MECHANISM_NAME). This routine checks that the mechanism argument
+ -- has the right form, and if not issues an error message. If the
+ -- argument has the right form then the Mechanism field of Ent is
+ -- set appropriately.
- elsif String_Equal
- (Name, Get_Name_From_CTC_Pragma (CTC))
- then
- Error_Msg_Sloc := Sloc (CTC);
- Error_Pragma ("name for pragma% is already used#");
- end if;
+ procedure Set_Rational_Profile;
+ -- Activate the set of configuration pragmas and permissions that make
+ -- up the Rational profile.
- CTC := Next_Pragma (CTC);
- end loop;
- end;
+ procedure Set_Ravenscar_Profile (N : Node_Id);
+ -- Activate the set of configuration pragmas and restrictions that make
+ -- up the Ravenscar Profile. N is the corresponding pragma node, which
+ -- is used for error messages on any constructs that violate the
+ -- profile.
- -- Chain spec CTC pragma to list for subprogram
+ ---------------------
+ -- Ada_2005_Pragma --
+ ---------------------
- Set_Next_Pragma (N, Spec_CTC_List (Contract (S)));
- Set_Spec_CTC_List (Contract (S), N);
- end Chain_CTC;
+ procedure Ada_2005_Pragma is
+ begin
+ if Ada_Version <= Ada_95 then
+ Check_Restriction (No_Implementation_Pragmas, N);
+ end if;
+ end Ada_2005_Pragma;
- -- Start of processing for Check_Test_Case
+ ---------------------
+ -- Ada_2012_Pragma --
+ ---------------------
+ procedure Ada_2012_Pragma is
begin
- -- First check pragma arguments
+ if Ada_Version <= Ada_2005 then
+ Check_Restriction (No_Implementation_Pragmas, N);
+ end if;
+ end Ada_2012_Pragma;
- GNAT_Pragma;
- Check_At_Least_N_Arguments (2);
- Check_At_Most_N_Arguments (4);
- Check_Arg_Order
- ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
+ --------------------------
+ -- Check_Ada_83_Warning --
+ --------------------------
- Check_Optional_Identifier (Arg1, Name_Name);
- Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ procedure Check_Ada_83_Warning is
+ begin
+ if Ada_Version = Ada_83 and then Comes_From_Source (N) then
+ Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
+ end if;
+ end Check_Ada_83_Warning;
- -- In ASIS mode, for a pragma generated from a source aspect, also
- -- analyze the original aspect expression.
+ ---------------------
+ -- Check_Arg_Count --
+ ---------------------
- if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
- Check_Expr_Is_Static_Expression
- (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String);
+ procedure Check_Arg_Count (Required : Nat) is
+ begin
+ if Arg_Count /= Required then
+ Error_Pragma ("wrong number of arguments for pragma%");
end if;
+ end Check_Arg_Count;
- Check_Optional_Identifier (Arg2, Name_Mode);
- Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
+ --------------------------------
+ -- Check_Arg_Is_External_Name --
+ --------------------------------
- if Arg_Count = 4 then
- Check_Identifier (Arg3, Name_Requires);
- Check_Identifier (Arg4, Name_Ensures);
+ procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
- elsif Arg_Count = 3 then
- Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
- end if;
+ begin
+ if Nkind (Argx) = N_Identifier then
+ return;
- -- Check pragma placement
+ else
+ Analyze_And_Resolve (Argx, Standard_String);
- if not Is_List_Member (N) then
- Pragma_Misplaced;
- end if;
+ if Is_OK_Static_Expression (Argx) then
+ return;
- -- Test-case should only appear in package spec unit
+ elsif Etype (Argx) = Any_Type then
+ raise Pragma_Exit;
- if Get_Source_Unit (N) = No_Unit
- or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
- N_Package_Declaration,
- N_Generic_Package_Declaration)
- then
- Pragma_Misplaced;
- end if;
+ -- An interesting special case, if we have a string literal and
+ -- we are in Ada 83 mode, then we allow it even though it will
+ -- not be flagged as static. This allows expected Ada 83 mode
+ -- use of external names which are string literals, even though
+ -- technically these are not static in Ada 83.
- -- Search prior declarations
+ elsif Ada_Version = Ada_83
+ and then Nkind (Argx) = N_String_Literal
+ then
+ return;
- P := N;
- while Present (Prev (P)) loop
- P := Prev (P);
+ -- Static expression that raises Constraint_Error. This has
+ -- already been flagged, so just exit from pragma processing.
- -- If the previous node is a generic subprogram, do not go to to
- -- the original node, which is the unanalyzed tree: we need to
- -- attach the test-case to the analyzed version at this point.
- -- They get propagated to the original tree when analyzing the
- -- corresponding body.
+ elsif Is_Static_Expression (Argx) then
+ raise Pragma_Exit;
+
+ -- Here we have a real error (non-static expression)
- if Nkind (P) not in N_Generic_Declaration then
- PO := Original_Node (P);
else
- PO := P;
+ Error_Msg_Name_1 := Pname;
+
+ declare
+ Msg : String :=
+ "argument for pragma% must be a identifier or "
+ & "static string expression!";
+ begin
+ Fix_Error (Msg);
+ Flag_Non_Static_Expr (Msg, Argx);
+ raise Pragma_Exit;
+ end;
end if;
+ end if;
+ end Check_Arg_Is_External_Name;
- -- Skip past prior pragma
+ -----------------------------
+ -- Check_Arg_Is_Identifier --
+ -----------------------------
- if Nkind (PO) = N_Pragma then
- null;
+ procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ begin
+ if Nkind (Argx) /= N_Identifier then
+ Error_Pragma_Arg
+ ("argument for pragma% must be identifier", Argx);
+ end if;
+ end Check_Arg_Is_Identifier;
- -- Skip stuff not coming from source
+ ----------------------------------
+ -- Check_Arg_Is_Integer_Literal --
+ ----------------------------------
- elsif not Comes_From_Source (PO) then
- null;
+ procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ begin
+ if Nkind (Argx) /= N_Integer_Literal then
+ Error_Pragma_Arg
+ ("argument for pragma% must be integer literal", Argx);
+ end if;
+ end Check_Arg_Is_Integer_Literal;
- -- Only remaining possibility is subprogram declaration. First
- -- check that it is declared directly in a package declaration.
- -- This may be either the package declaration for the current unit
- -- being defined or a local package declaration.
+ -------------------------------------------
+ -- Check_Arg_Is_Library_Level_Local_Name --
+ -------------------------------------------
- elsif not Present (Parent (Parent (PO)))
- or else not Present (Parent (Parent (Parent (PO))))
- or else not Nkind_In (Parent (Parent (PO)),
- N_Package_Declaration,
- N_Generic_Package_Declaration)
- then
- Pragma_Misplaced;
+ -- LOCAL_NAME ::=
+ -- DIRECT_NAME
+ -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
+ -- | library_unit_NAME
- else
- Chain_CTC (PO);
- return;
- end if;
- end loop;
+ procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
+ begin
+ Check_Arg_Is_Local_Name (Arg);
- -- If we fall through, pragma was misplaced
+ if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
+ and then Comes_From_Source (N)
+ then
+ Error_Pragma_Arg
+ ("argument for pragma% must be library level entity", Arg);
+ end if;
+ end Check_Arg_Is_Library_Level_Local_Name;
- Pragma_Misplaced;
- end Check_Test_Case;
+ -----------------------------
+ -- Check_Arg_Is_Local_Name --
+ -----------------------------
- --------------------------------------
- -- Check_Valid_Configuration_Pragma --
- --------------------------------------
+ -- LOCAL_NAME ::=
+ -- DIRECT_NAME
+ -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
+ -- | library_unit_NAME
- -- A configuration pragma must appear in the context clause of a
- -- compilation unit, and only other pragmas may precede it. Note that
- -- the test also allows use in a configuration pragma file.
+ procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
- procedure Check_Valid_Configuration_Pragma is
begin
- if not Is_Configuration_Pragma then
- Error_Pragma ("incorrect placement for configuration pragma%");
- end if;
- end Check_Valid_Configuration_Pragma;
+ Analyze (Argx);
- -------------------------------------
- -- Check_Valid_Library_Unit_Pragma --
- -------------------------------------
+ if Nkind (Argx) not in N_Direct_Name
+ and then (Nkind (Argx) /= N_Attribute_Reference
+ or else Present (Expressions (Argx))
+ or else Nkind (Prefix (Argx)) /= N_Identifier)
+ and then (not Is_Entity_Name (Argx)
+ or else not Is_Compilation_Unit (Entity (Argx)))
+ then
+ Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
+ end if;
- procedure Check_Valid_Library_Unit_Pragma is
- Plist : List_Id;
- Parent_Node : Node_Id;
- Unit_Name : Entity_Id;
- Unit_Kind : Node_Kind;
- Unit_Node : Node_Id;
- Sindex : Source_File_Index;
+ -- No further check required if not an entity name
- begin
- if not Is_List_Member (N) then
- Pragma_Misplaced;
+ if not Is_Entity_Name (Argx) then
+ null;
else
- Plist := List_Containing (N);
- Parent_Node := Parent (Plist);
+ declare
+ OK : Boolean;
+ Ent : constant Entity_Id := Entity (Argx);
+ Scop : constant Entity_Id := Scope (Ent);
- if Parent_Node = Empty then
- Pragma_Misplaced;
+ begin
+ -- Case of a pragma applied to a compilation unit: pragma must
+ -- occur immediately after the program unit in the compilation.
- -- Case of pragma appearing after a compilation unit. In this case
- -- it must have an argument with the corresponding name and must
- -- be part of the following pragmas of its parent.
+ if Is_Compilation_Unit (Ent) then
+ declare
+ Decl : constant Node_Id := Unit_Declaration_Node (Ent);
- elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
- if Plist /= Pragmas_After (Parent_Node) then
- Pragma_Misplaced;
+ begin
+ -- Case of pragma placed immediately after spec
- elsif Arg_Count = 0 then
- Error_Pragma
- ("argument required if outside compilation unit");
+ if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
+ OK := True;
- else
- Check_No_Identifiers;
- Check_Arg_Count (1);
- Unit_Node := Unit (Parent (Parent_Node));
- Unit_Kind := Nkind (Unit_Node);
+ -- Case of pragma placed immediately after body
- Analyze (Get_Pragma_Arg (Arg1));
+ elsif Nkind (Decl) = N_Subprogram_Declaration
+ and then Present (Corresponding_Body (Decl))
+ then
+ OK := Parent (N) =
+ Aux_Decls_Node
+ (Parent (Unit_Declaration_Node
+ (Corresponding_Body (Decl))));
- if Unit_Kind = N_Generic_Subprogram_Declaration
- or else Unit_Kind = N_Subprogram_Declaration
- then
- Unit_Name := Defining_Entity (Unit_Node);
+ -- All other cases are illegal
- elsif Unit_Kind in N_Generic_Instantiation then
- Unit_Name := Defining_Entity (Unit_Node);
+ else
+ OK := False;
+ end if;
+ end;
- else
- Unit_Name := Cunit_Entity (Current_Sem_Unit);
- end if;
+ -- Special restricted placement rule from 10.2.1(11.8/2)
- if Chars (Unit_Name) /=
- Chars (Entity (Get_Pragma_Arg (Arg1)))
- then
- Error_Pragma_Arg
- ("pragma% argument is not current unit name", Arg1);
- end if;
+ elsif Is_Generic_Formal (Ent)
+ and then Prag_Id = Pragma_Preelaborable_Initialization
+ then
+ OK := List_Containing (N) =
+ Generic_Formal_Declarations
+ (Unit_Declaration_Node (Scop));
- if Ekind (Unit_Name) = E_Package
- and then Present (Renamed_Entity (Unit_Name))
- then
- Error_Pragma ("pragma% not allowed for renamed package");
- end if;
+ -- Default case, just check that the pragma occurs in the scope
+ -- of the entity denoted by the name.
+
+ else
+ OK := Current_Scope = Scop;
end if;
- -- Pragma appears other than after a compilation unit
+ if not OK then
+ Error_Pragma_Arg
+ ("pragma% argument must be in same declarative part", Arg);
+ end if;
+ end;
+ end if;
+ end Check_Arg_Is_Local_Name;
- else
- -- Here we check for the generic instantiation case and also
- -- for the case of processing a generic formal package. We
- -- detect these cases by noting that the Sloc on the node
- -- does not belong to the current compilation unit.
+ ---------------------------------
+ -- Check_Arg_Is_Locking_Policy --
+ ---------------------------------
- Sindex := Source_Index (Current_Sem_Unit);
+ procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
- if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
- Rewrite (N, Make_Null_Statement (Loc));
- return;
+ begin
+ Check_Arg_Is_Identifier (Argx);
- -- If before first declaration, the pragma applies to the
- -- enclosing unit, and the name if present must be this name.
+ if not Is_Locking_Policy_Name (Chars (Argx)) then
+ Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
+ end if;
+ end Check_Arg_Is_Locking_Policy;
- elsif Is_Before_First_Decl (N, Plist) then
- Unit_Node := Unit_Declaration_Node (Current_Scope);
- Unit_Kind := Nkind (Unit_Node);
+ -----------------------------------------------
+ -- Check_Arg_Is_Partition_Elaboration_Policy --
+ -----------------------------------------------
- if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
- Pragma_Misplaced;
+ procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
- elsif Unit_Kind = N_Subprogram_Body
- and then not Acts_As_Spec (Unit_Node)
- then
- Pragma_Misplaced;
+ begin
+ Check_Arg_Is_Identifier (Argx);
- elsif Nkind (Parent_Node) = N_Package_Body then
- Pragma_Misplaced;
+ if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
+ Error_Pragma_Arg
+ ("& is not a valid partition elaboration policy name", Argx);
+ end if;
+ end Check_Arg_Is_Partition_Elaboration_Policy;
- elsif Nkind (Parent_Node) = N_Package_Specification
- and then Plist = Private_Declarations (Parent_Node)
- then
- Pragma_Misplaced;
+ -------------------------
+ -- Check_Arg_Is_One_Of --
+ -------------------------
- elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
- or else Nkind (Parent_Node) =
- N_Generic_Subprogram_Declaration)
- and then Plist = Generic_Formal_Declarations (Parent_Node)
- then
- Pragma_Misplaced;
+ procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
- elsif Arg_Count > 0 then
- Analyze (Get_Pragma_Arg (Arg1));
+ begin
+ Check_Arg_Is_Identifier (Argx);
+
+ if not Nam_In (Chars (Argx), N1, N2) then
+ Error_Msg_Name_2 := N1;
+ Error_Msg_Name_3 := N2;
+ Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
+ end if;
+ end Check_Arg_Is_One_Of;
+
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
+ N1, N2, N3 : Name_Id)
+ is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ Check_Arg_Is_Identifier (Argx);
+
+ if not Nam_In (Chars (Argx), N1, N2, N3) then
+ Error_Pragma_Arg ("invalid argument for pragma%", Argx);
+ end if;
+ end Check_Arg_Is_One_Of;
- if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
- Error_Pragma_Arg
- ("name in pragma% must be enclosing unit", Arg1);
- end if;
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
+ N1, N2, N3, N4 : Name_Id)
+ is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
- -- It is legal to have no argument in this context
+ begin
+ Check_Arg_Is_Identifier (Argx);
- else
- return;
- end if;
+ if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
+ Error_Pragma_Arg ("invalid argument for pragma%", Argx);
+ end if;
+ end Check_Arg_Is_One_Of;
- -- Error if not before first declaration. This is because a
- -- library unit pragma argument must be the name of a library
- -- unit (RM 10.1.5(7)), but the only names permitted in this
- -- context are (RM 10.1.5(6)) names of subprogram declarations,
- -- generic subprogram declarations or generic instantiations.
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
+ N1, N2, N3, N4, N5 : Name_Id)
+ is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
- else
- Error_Pragma
- ("pragma% misplaced, must be before first declaration");
- end if;
- end if;
+ begin
+ Check_Arg_Is_Identifier (Argx);
+
+ if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
+ Error_Pragma_Arg ("invalid argument for pragma%", Argx);
end if;
- end Check_Valid_Library_Unit_Pragma;
+ end Check_Arg_Is_One_Of;
- -------------------
- -- Check_Variant --
- -------------------
+ ---------------------------------
+ -- Check_Arg_Is_Queuing_Policy --
+ ---------------------------------
- procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
- Clist : constant Node_Id := Component_List (Variant);
- Comp : Node_Id;
+ procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
begin
- Comp := First (Component_Items (Clist));
- while Present (Comp) loop
- Check_Component (Comp, UU_Typ, In_Variant_Part => True);
- Next (Comp);
- end loop;
- end Check_Variant;
+ Check_Arg_Is_Identifier (Argx);
- ------------------
- -- Error_Pragma --
- ------------------
+ if not Is_Queuing_Policy_Name (Chars (Argx)) then
+ Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
+ end if;
+ end Check_Arg_Is_Queuing_Policy;
- procedure Error_Pragma (Msg : String) is
- MsgF : String := Msg;
+ ------------------------------------
+ -- Check_Arg_Is_Static_Expression --
+ ------------------------------------
+
+ procedure Check_Arg_Is_Static_Expression
+ (Arg : Node_Id;
+ Typ : Entity_Id := Empty)
+ is
begin
- Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_N (MsgF, N);
- raise Pragma_Exit;
- end Error_Pragma;
+ Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ);
+ end Check_Arg_Is_Static_Expression;
- ----------------------
- -- Error_Pragma_Arg --
- ----------------------
+ ------------------------------------------
+ -- Check_Arg_Is_Task_Dispatching_Policy --
+ ------------------------------------------
- procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
- MsgF : String := Msg;
- begin
- Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
- raise Pragma_Exit;
- end Error_Pragma_Arg;
+ procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
- procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
- MsgF : String := Msg1;
begin
- Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
- Error_Pragma_Arg (Msg2, Arg);
- end Error_Pragma_Arg;
+ Check_Arg_Is_Identifier (Argx);
- ----------------------------
- -- Error_Pragma_Arg_Ident --
- ----------------------------
+ if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
+ Error_Pragma_Arg
+ ("& is not a valid task dispatching policy name", Argx);
+ end if;
+ end Check_Arg_Is_Task_Dispatching_Policy;
- procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
- MsgF : String := Msg;
- begin
- Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_N (MsgF, Arg);
- raise Pragma_Exit;
- end Error_Pragma_Arg_Ident;
+ ---------------------
+ -- Check_Arg_Order --
+ ---------------------
- ----------------------
- -- Error_Pragma_Ref --
- ----------------------
+ procedure Check_Arg_Order (Names : Name_List) is
+ Arg : Node_Id;
+
+ Highest_So_Far : Natural := 0;
+ -- Highest index in Names seen do far
- procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
- MsgF : String := Msg;
begin
- Error_Msg_Name_1 := Pname;
- Fix_Error (MsgF);
- Error_Msg_Sloc := Sloc (Ref);
- Error_Msg_NE (MsgF, N, Ref);
- raise Pragma_Exit;
- end Error_Pragma_Ref;
+ Arg := Arg1;
+ for J in 1 .. Arg_Count loop
+ if Chars (Arg) /= No_Name then
+ for K in Names'Range loop
+ if Chars (Arg) = Names (K) then
+ if K < Highest_So_Far then
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N
+ ("parameters out of order for pragma%", Arg);
+ Error_Msg_Name_1 := Names (K);
+ Error_Msg_Name_2 := Names (Highest_So_Far);
+ Error_Msg_N ("\% must appear before %", Arg);
+ raise Pragma_Exit;
- ------------------------
- -- Find_Lib_Unit_Name --
- ------------------------
+ else
+ Highest_So_Far := K;
+ end if;
+ end if;
+ end loop;
+ end if;
- function Find_Lib_Unit_Name return Entity_Id is
+ Arg := Next (Arg);
+ end loop;
+ end Check_Arg_Order;
+
+ --------------------------------
+ -- Check_At_Least_N_Arguments --
+ --------------------------------
+
+ procedure Check_At_Least_N_Arguments (N : Nat) is
begin
- -- Return inner compilation unit entity, for case of nested
- -- categorization pragmas. This happens in generic unit.
+ if Arg_Count < N then
+ Error_Pragma ("too few arguments for pragma%");
+ end if;
+ end Check_At_Least_N_Arguments;
- if Nkind (Parent (N)) = N_Package_Specification
- and then Defining_Entity (Parent (N)) /= Current_Scope
- then
- return Defining_Entity (Parent (N));
- else
- return Current_Scope;
+ -------------------------------
+ -- Check_At_Most_N_Arguments --
+ -------------------------------
+
+ procedure Check_At_Most_N_Arguments (N : Nat) is
+ Arg : Node_Id;
+ begin
+ if Arg_Count > N then
+ Arg := Arg1;
+ for J in 1 .. N loop
+ Next (Arg);
+ Error_Pragma_Arg ("too many arguments for pragma%", Arg);
+ end loop;
end if;
- end Find_Lib_Unit_Name;
+ end Check_At_Most_N_Arguments;
- ----------------------------
- -- Find_Program_Unit_Name --
- ----------------------------
+ ---------------------
+ -- Check_Component --
+ ---------------------
- procedure Find_Program_Unit_Name (Id : Node_Id) is
- Unit_Name : Entity_Id;
- Unit_Kind : Node_Kind;
- P : constant Node_Id := Parent (N);
+ procedure Check_Component
+ (Comp : Node_Id;
+ UU_Typ : Entity_Id;
+ In_Variant_Part : Boolean := False)
+ is
+ Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
+ Sindic : constant Node_Id :=
+ Subtype_Indication (Component_Definition (Comp));
+ Typ : constant Entity_Id := Etype (Comp_Id);
begin
- if Nkind (P) = N_Compilation_Unit then
- Unit_Kind := Nkind (Unit (P));
+ -- Ada 2005 (AI-216): If a component subtype is subject to a per-
+ -- object constraint, then the component type shall be an Unchecked_
+ -- Union.
- if Unit_Kind = N_Subprogram_Declaration
- or else Unit_Kind = N_Package_Declaration
- or else Unit_Kind in N_Generic_Declaration
- then
- Unit_Name := Defining_Entity (Unit (P));
+ if Nkind (Sindic) = N_Subtype_Indication
+ and then Has_Per_Object_Constraint (Comp_Id)
+ and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
+ then
+ Error_Msg_N
+ ("component subtype subject to per-object constraint "
+ & "must be an Unchecked_Union", Comp);
- if Chars (Id) = Chars (Unit_Name) then
- Set_Entity (Id, Unit_Name);
- Set_Etype (Id, Etype (Unit_Name));
- else
- Set_Etype (Id, Any_Type);
- Error_Pragma
- ("cannot find program unit referenced by pragma%");
- end if;
+ -- Ada 2012 (AI05-0026): For an unchecked union type declared within
+ -- the body of a generic unit, or within the body of any of its
+ -- descendant library units, no part of the type of a component
+ -- declared in a variant_part of the unchecked union type shall be of
+ -- a formal private type or formal private extension declared within
+ -- the formal part of the generic unit.
+
+ elsif Ada_Version >= Ada_2012
+ and then In_Generic_Body (UU_Typ)
+ and then In_Variant_Part
+ and then Is_Private_Type (Typ)
+ and then Is_Generic_Type (Typ)
+ then
+ Error_Msg_N
+ ("component of unchecked union cannot be of generic type", Comp);
- else
- Set_Etype (Id, Any_Type);
- Error_Pragma ("pragma% inapplicable to this unit");
- end if;
+ elsif Needs_Finalization (Typ) then
+ Error_Msg_N
+ ("component of unchecked union cannot be controlled", Comp);
- else
- Analyze (Id);
+ elsif Has_Task (Typ) then
+ Error_Msg_N
+ ("component of unchecked union cannot have tasks", Comp);
end if;
- end Find_Program_Unit_Name;
+ end Check_Component;
- -----------------------------------------
- -- Find_Unique_Parameterless_Procedure --
- -----------------------------------------
+ ----------------------------
+ -- Check_Duplicate_Pragma --
+ ----------------------------
- function Find_Unique_Parameterless_Procedure
- (Name : Entity_Id;
- Arg : Node_Id) return Entity_Id
- is
- Proc : Entity_Id := Empty;
+ procedure Check_Duplicate_Pragma (E : Entity_Id) is
+ Id : Entity_Id := E;
+ P : Node_Id;
begin
- -- The body of this procedure needs some comments ???
+ -- Nothing to do if this pragma comes from an aspect specification,
+ -- since we could not be duplicating a pragma, and we dealt with the
+ -- case of duplicated aspects in Analyze_Aspect_Specifications.
- if not Is_Entity_Name (Name) then
- Error_Pragma_Arg
- ("argument of pragma% must be entity name", Arg);
+ if From_Aspect_Specification (N) then
+ return;
+ end if;
- elsif not Is_Overloaded (Name) then
- Proc := Entity (Name);
+ -- Otherwise current pragma may duplicate previous pragma or a
+ -- previously given aspect specification or attribute definition
+ -- clause for the same pragma.
- if Ekind (Proc) /= E_Procedure
- or else Present (First_Formal (Proc))
- then
- Error_Pragma_Arg
- ("argument of pragma% must be parameterless procedure", Arg);
- end if;
+ P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
- else
- declare
- Found : Boolean := False;
- It : Interp;
- Index : Interp_Index;
+ if Present (P) then
+ Error_Msg_Name_1 := Pragma_Name (N);
+ Error_Msg_Sloc := Sloc (P);
- begin
- Get_First_Interp (Name, Index, It);
- while Present (It.Nam) loop
- Proc := It.Nam;
+ -- For a single protected or a single task object, the error is
+ -- issued on the original entity.
- if Ekind (Proc) = E_Procedure
- and then No (First_Formal (Proc))
- then
- if not Found then
- Found := True;
- Set_Entity (Name, Proc);
- Set_Is_Overloaded (Name, False);
- else
- Error_Pragma_Arg
- ("ambiguous handler name for pragma% ", Arg);
- end if;
- end if;
+ if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
+ Id := Defining_Identifier (Original_Node (Parent (Id)));
+ end if;
- Get_Next_Interp (Index, It);
- end loop;
+ if Nkind (P) = N_Aspect_Specification
+ or else From_Aspect_Specification (P)
+ then
+ Error_Msg_NE ("aspect% for & previously given#", N, Id);
+ else
+ Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
+ end if;
- if not Found then
- Error_Pragma_Arg
- ("argument of pragma% must be parameterless procedure",
- Arg);
- else
- Proc := Entity (Name);
- end if;
- end;
+ raise Pragma_Exit;
end if;
+ end Check_Duplicate_Pragma;
- return Proc;
- end Find_Unique_Parameterless_Procedure;
+ ----------------------------------
+ -- Check_Duplicated_Export_Name --
+ ----------------------------------
- ---------------
- -- Fix_Error --
- ---------------
+ procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
+ String_Val : constant String_Id := Strval (Nam);
- procedure Fix_Error (Msg : in out String) is
begin
- -- If we have a rewriting of another pragma, go to that pragma
+ -- We are only interested in the export case, and in the case of
+ -- generics, it is the instance, not the template, that is the
+ -- problem (the template will generate a warning in any case).
- if Is_Rewrite_Substitution (N)
- and then Nkind (Original_Node (N)) = N_Pragma
+ if not Inside_A_Generic
+ and then (Prag_Id = Pragma_Export
+ or else
+ Prag_Id = Pragma_Export_Procedure
+ or else
+ Prag_Id = Pragma_Export_Valued_Procedure
+ or else
+ Prag_Id = Pragma_Export_Function)
then
- Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
- end if;
-
- -- Case where pragma comes from an aspect specification
-
- if From_Aspect_Specification (N) then
-
- -- Change appearence of "pragma" in message to "aspect"
-
- for J in Msg'First .. Msg'Last - 5 loop
- if Msg (J .. J + 5) = "pragma" then
- Msg (J .. J + 5) := "aspect";
+ for J in Externals.First .. Externals.Last loop
+ if String_Equal (String_Val, Strval (Externals.Table (J))) then
+ Error_Msg_Sloc := Sloc (Externals.Table (J));
+ Error_Msg_N ("external name duplicates name given#", Nam);
+ exit;
end if;
end loop;
- -- Get name from corresponding aspect
-
- Error_Msg_Name_1 := Original_Name (N);
+ Externals.Append (Nam);
end if;
- end Fix_Error;
+ end Check_Duplicated_Export_Name;
- -------------------------
- -- Gather_Associations --
- -------------------------
+ -------------------------------------
+ -- Check_Expr_Is_Static_Expression --
+ -------------------------------------
- procedure Gather_Associations
- (Names : Name_List;
- Args : out Args_List)
+ procedure Check_Expr_Is_Static_Expression
+ (Expr : Node_Id;
+ Typ : Entity_Id := Empty)
is
- Arg : Node_Id;
-
begin
- -- Initialize all parameters to Empty
+ if Present (Typ) then
+ Analyze_And_Resolve (Expr, Typ);
+ else
+ Analyze_And_Resolve (Expr);
+ end if;
- for J in Args'Range loop
- Args (J) := Empty;
- end loop;
+ if Is_OK_Static_Expression (Expr) then
+ return;
- -- That's all we have to do if there are no argument associations
+ elsif Etype (Expr) = Any_Type then
+ raise Pragma_Exit;
- if No (Pragma_Argument_Associations (N)) then
+ -- An interesting special case, if we have a string literal and we
+ -- are in Ada 83 mode, then we allow it even though it will not be
+ -- flagged as static. This allows the use of Ada 95 pragmas like
+ -- Import in Ada 83 mode. They will of course be flagged with
+ -- warnings as usual, but will not cause errors.
+
+ elsif Ada_Version = Ada_83
+ and then Nkind (Expr) = N_String_Literal
+ then
return;
- end if;
- -- Otherwise first deal with any positional parameters present
+ -- Static expression that raises Constraint_Error. This has already
+ -- been flagged, so just exit from pragma processing.
- Arg := First (Pragma_Argument_Associations (N));
- for Index in Args'Range loop
- exit when No (Arg) or else Chars (Arg) /= No_Name;
- Args (Index) := Get_Pragma_Arg (Arg);
- Next (Arg);
- end loop;
+ elsif Is_Static_Expression (Expr) then
+ raise Pragma_Exit;
- -- Positional parameters all processed, if any left, then we
- -- have too many positional parameters.
+ -- Finally, we have a real error
- if Present (Arg) and then Chars (Arg) = No_Name then
- Error_Pragma_Arg
- ("too many positional associations for pragma%", Arg);
+ else
+ Error_Msg_Name_1 := Pname;
+
+ declare
+ Msg : String :=
+ "argument for pragma% must be a static expression!";
+ begin
+ Fix_Error (Msg);
+ Flag_Non_Static_Expr (Msg, Expr);
+ end;
+
+ raise Pragma_Exit;
end if;
+ end Check_Expr_Is_Static_Expression;
- -- Process named parameters if any are present
+ -------------------------
+ -- Check_First_Subtype --
+ -------------------------
- while Present (Arg) loop
- if Chars (Arg) = No_Name then
- Error_Pragma_Arg
- ("positional association cannot follow named association",
- Arg);
+ procedure Check_First_Subtype (Arg : Node_Id) is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ Ent : constant Entity_Id := Entity (Argx);
- else
- for Index in Names'Range loop
- if Names (Index) = Chars (Arg) then
- if Present (Args (Index)) then
- Error_Pragma_Arg
- ("duplicate argument association for pragma%", Arg);
- else
- Args (Index) := Get_Pragma_Arg (Arg);
- exit;
- end if;
- end if;
+ begin
+ if Is_First_Subtype (Ent) then
+ null;
- if Index = Names'Last then
- Error_Msg_Name_1 := Pname;
- Error_Msg_N ("pragma% does not allow & argument", Arg);
+ elsif Is_Type (Ent) then
+ Error_Pragma_Arg
+ ("pragma% cannot apply to subtype", Argx);
- -- Check for possible misspelling
+ elsif Is_Object (Ent) then
+ Error_Pragma_Arg
+ ("pragma% cannot apply to object, requires a type", Argx);
+
+ else
+ Error_Pragma_Arg
+ ("pragma% cannot apply to&, requires a type", Argx);
+ end if;
+ end Check_First_Subtype;
- for Index1 in Names'Range loop
- if Is_Bad_Spelling_Of
- (Chars (Arg), Names (Index1))
- then
- Error_Msg_Name_1 := Names (Index1);
- Error_Msg_N -- CODEFIX
- ("\possible misspelling of%", Arg);
- exit;
- end if;
- end loop;
+ ----------------------
+ -- Check_Identifier --
+ ----------------------
- raise Pragma_Exit;
- end if;
- end loop;
+ procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
+ begin
+ if Present (Arg)
+ and then Nkind (Arg) = N_Pragma_Argument_Association
+ then
+ if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_Name_2 := Id;
+ Error_Msg_N ("pragma% argument expects identifier%", Arg);
+ raise Pragma_Exit;
end if;
+ end if;
+ end Check_Identifier;
- Next (Arg);
- end loop;
- end Gather_Associations;
-
- -----------------
- -- GNAT_Pragma --
- -----------------
+ --------------------------------
+ -- Check_Identifier_Is_One_Of --
+ --------------------------------
- procedure GNAT_Pragma is
+ procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
begin
- -- We need to check the No_Implementation_Pragmas restriction for
- -- the case of a pragma from source. Note that the case of aspects
- -- generating corresponding pragmas marks these pragmas as not being
- -- from source, so this test also catches that case.
+ if Present (Arg)
+ and then Nkind (Arg) = N_Pragma_Argument_Association
+ then
+ if Chars (Arg) = No_Name then
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N ("pragma% argument expects an identifier", Arg);
+ raise Pragma_Exit;
- if Comes_From_Source (N) then
- Check_Restriction (No_Implementation_Pragmas, N);
+ elsif Chars (Arg) /= N1
+ and then Chars (Arg) /= N2
+ then
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N ("invalid identifier for pragma% argument", Arg);
+ raise Pragma_Exit;
+ end if;
end if;
- end GNAT_Pragma;
+ end Check_Identifier_Is_One_Of;
- --------------------------
- -- Is_Before_First_Decl --
- --------------------------
+ ---------------------------
+ -- Check_In_Main_Program --
+ ---------------------------
- function Is_Before_First_Decl
- (Pragma_Node : Node_Id;
- Decls : List_Id) return Boolean
- is
- Item : Node_Id := First (Decls);
+ procedure Check_In_Main_Program is
+ P : constant Node_Id := Parent (N);
begin
- -- Only other pragmas can come before this pragma
-
- loop
- if No (Item) or else Nkind (Item) /= N_Pragma then
- return False;
+ -- Must be at in subprogram body
- elsif Item = Pragma_Node then
- return True;
- end if;
+ if Nkind (P) /= N_Subprogram_Body then
+ Error_Pragma ("% pragma allowed only in subprogram");
- Next (Item);
- end loop;
- end Is_Before_First_Decl;
+ -- Otherwise warn if obviously not main program
- -----------------------------
- -- Is_Configuration_Pragma --
- -----------------------------
+ elsif Present (Parameter_Specifications (Specification (P)))
+ or else not Is_Compilation_Unit (Defining_Entity (P))
+ then
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N
+ ("??pragma% is only effective in main program", N);
+ end if;
+ end Check_In_Main_Program;
- -- A configuration pragma must appear in the context clause of a
- -- compilation unit, and only other pragmas may precede it. Note that
- -- the test below also permits use in a configuration pragma file.
+ ---------------------------------------
+ -- Check_Interrupt_Or_Attach_Handler --
+ ---------------------------------------
- function Is_Configuration_Pragma return Boolean is
- Lis : constant List_Id := List_Containing (N);
- Par : constant Node_Id := Parent (N);
- Prg : Node_Id;
+ procedure Check_Interrupt_Or_Attach_Handler is
+ Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
+ Handler_Proc, Proc_Scope : Entity_Id;
begin
- -- If no parent, then we are in the configuration pragma file,
- -- so the placement is definitely appropriate.
-
- if No (Par) then
- return True;
+ Analyze (Arg1_X);
- -- Otherwise we must be in the context clause of a compilation unit
- -- and the only thing allowed before us in the context list is more
- -- configuration pragmas.
+ if Prag_Id = Pragma_Interrupt_Handler then
+ Check_Restriction (No_Dynamic_Attachment, N);
+ end if;
- elsif Nkind (Par) = N_Compilation_Unit
- and then Context_Items (Par) = Lis
- then
- Prg := First (Lis);
+ Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
+ Proc_Scope := Scope (Handler_Proc);
- loop
- if Prg = N then
- return True;
- elsif Nkind (Prg) /= N_Pragma then
- return False;
- end if;
+ -- On AAMP only, a pragma Interrupt_Handler is supported for
+ -- nonprotected parameterless procedures.
- Next (Prg);
- end loop;
+ if not AAMP_On_Target
+ or else Prag_Id = Pragma_Attach_Handler
+ then
+ if Ekind (Proc_Scope) /= E_Protected_Type then
+ Error_Pragma_Arg
+ ("argument of pragma% must be protected procedure", Arg1);
+ end if;
- else
- return False;
+ if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
+ Error_Pragma ("pragma% must be in protected definition");
+ end if;
end if;
- end Is_Configuration_Pragma;
- --------------------------
- -- Is_In_Context_Clause --
- --------------------------
-
- function Is_In_Context_Clause return Boolean is
- Plist : List_Id;
- Parent_Node : Node_Id;
+ if not Is_Library_Level_Entity (Proc_Scope)
+ or else (AAMP_On_Target
+ and then not Is_Library_Level_Entity (Handler_Proc))
+ then
+ Error_Pragma_Arg
+ ("argument for pragma% must be library level entity", Arg1);
+ end if;
- begin
- if not Is_List_Member (N) then
- return False;
+ -- AI05-0033: A pragma cannot appear within a generic body, because
+ -- instance can be in a nested scope. The check that protected type
+ -- is itself a library-level declaration is done elsewhere.
- else
- Plist := List_Containing (N);
- Parent_Node := Parent (Plist);
+ -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
+ -- handle code prior to AI-0033. Analysis tools typically are not
+ -- interested in this pragma in any case, so no need to worry too
+ -- much about its placement.
- if Parent_Node = Empty
- or else Nkind (Parent_Node) /= N_Compilation_Unit
- or else Context_Items (Parent_Node) /= Plist
+ if Inside_A_Generic then
+ if Ekind (Scope (Current_Scope)) = E_Generic_Package
+ and then In_Package_Body (Scope (Current_Scope))
+ and then not Relaxed_RM_Semantics
then
- return False;
+ Error_Pragma ("pragma% cannot be used inside a generic");
end if;
end if;
-
- return True;
- end Is_In_Context_Clause;
+ end Check_Interrupt_Or_Attach_Handler;
---------------------------------
- -- Is_Static_String_Expression --
+ -- Check_Loop_Pragma_Placement --
---------------------------------
- function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ procedure Check_Loop_Pragma_Placement is
+ procedure Placement_Error (Constr : Node_Id);
+ pragma No_Return (Placement_Error);
+ -- Node Constr denotes the last loop restricted construct before we
+ -- encountered an illegal relation between enclosing constructs. Emit
+ -- an error depending on what Constr was.
+
+ ---------------------
+ -- Placement_Error --
+ ---------------------
+
+ procedure Placement_Error (Constr : Node_Id) is
+ begin
+ if Nkind (Constr) = N_Pragma then
+ Error_Pragma
+ ("pragma % must appear immediately within the statements "
+ & "of a loop");
+ else
+ Error_Pragma_Arg
+ ("block containing pragma % must appear immediately within "
+ & "the statements of a loop", Constr);
+ end if;
+ end Placement_Error;
+
+ -- Local declarations
+
+ Prev : Node_Id;
+ Stmt : Node_Id;
+
+ -- Start of processing for Check_Loop_Pragma_Placement
begin
- Analyze_And_Resolve (Argx);
- return Is_OK_Static_Expression (Argx)
- and then Nkind (Argx) = N_String_Literal;
- end Is_Static_String_Expression;
+ Prev := N;
+ Stmt := Parent (N);
+ while Present (Stmt) loop
+
+ -- The pragma or previous block must appear immediately within the
+ -- current block's declarative or statement part.
+
+ if Nkind (Stmt) = N_Block_Statement then
+ if (No (Declarations (Stmt))
+ or else List_Containing (Prev) /= Declarations (Stmt))
+ and then
+ List_Containing (Prev) /=
+ Statements (Handled_Statement_Sequence (Stmt))
+ then
+ Placement_Error (Prev);
+ return;
+
+ -- Keep inspecting the parents because we are now within a
+ -- chain of nested blocks.
- ----------------------
- -- Pragma_Misplaced --
- ----------------------
+ else
+ Prev := Stmt;
+ Stmt := Parent (Stmt);
+ end if;
- procedure Pragma_Misplaced is
- begin
- Error_Pragma ("incorrect placement of pragma%");
- end Pragma_Misplaced;
+ -- The pragma or previous block must appear immediately within the
+ -- statements of the loop.
- ------------------------------------
- -- Process_Atomic_Shared_Volatile --
- ------------------------------------
+ elsif Nkind (Stmt) = N_Loop_Statement then
+ if List_Containing (Prev) /= Statements (Stmt) then
+ Placement_Error (Prev);
+ end if;
- procedure Process_Atomic_Shared_Volatile is
- E_Id : Node_Id;
- E : Entity_Id;
- D : Node_Id;
- K : Node_Kind;
- Utyp : Entity_Id;
+ -- Stop the traversal because we reached the innermost loop
+ -- regardless of whether we encountered an error or not.
- procedure Set_Atomic (E : Entity_Id);
- -- Set given type as atomic, and if no explicit alignment was given,
- -- set alignment to unknown, since back end knows what the alignment
- -- requirements are for atomic arrays. Note: this step is necessary
- -- for derived types.
+ return;
- ----------------
- -- Set_Atomic --
- ----------------
+ -- Ignore a handled statement sequence. Note that this node may
+ -- be related to a subprogram body in which case we will emit an
+ -- error on the next iteration of the search.
- procedure Set_Atomic (E : Entity_Id) is
- begin
- Set_Is_Atomic (E);
+ elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
+ Stmt := Parent (Stmt);
- if not Has_Alignment_Clause (E) then
- Set_Alignment (E, Uint_0);
- end if;
- end Set_Atomic;
+ -- Any other statement breaks the chain from the pragma to the
+ -- loop.
- -- Start of processing for Process_Atomic_Shared_Volatile
+ else
+ Placement_Error (Prev);
+ return;
+ end if;
+ end loop;
+ end Check_Loop_Pragma_Placement;
- begin
- Check_Ada_83_Warning;
- Check_No_Identifiers;
- Check_Arg_Count (1);
- Check_Arg_Is_Local_Name (Arg1);
- E_Id := Get_Pragma_Arg (Arg1);
+ -------------------------------------------
+ -- Check_Is_In_Decl_Part_Or_Package_Spec --
+ -------------------------------------------
- if Etype (E_Id) = Any_Type then
- return;
- end if;
+ procedure Check_Is_In_Decl_Part_Or_Package_Spec is
+ P : Node_Id;
- E := Entity (E_Id);
- D := Declaration_Node (E);
- K := Nkind (D);
+ begin
+ P := Parent (N);
+ loop
+ if No (P) then
+ exit;
- -- Check duplicate before we chain ourselves!
+ elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
+ exit;
- Check_Duplicate_Pragma (E);
+ elsif Nkind_In (P, N_Package_Specification,
+ N_Block_Statement)
+ then
+ return;
- -- Now check appropriateness of the entity
+ -- Note: the following tests seem a little peculiar, because
+ -- they test for bodies, but if we were in the statement part
+ -- of the body, we would already have hit the handled statement
+ -- sequence, so the only way we get here is by being in the
+ -- declarative part of the body.
- if Is_Type (E) then
- if Rep_Item_Too_Early (E, N)
- or else
- Rep_Item_Too_Late (E, N)
+ elsif Nkind_In (P, N_Subprogram_Body,
+ N_Package_Body,
+ N_Task_Body,
+ N_Entry_Body)
then
return;
- else
- Check_First_Subtype (Arg1);
end if;
- if Prag_Id /= Pragma_Volatile then
- Set_Atomic (E);
- Set_Atomic (Underlying_Type (E));
- Set_Atomic (Base_Type (E));
- end if;
+ P := Parent (P);
+ end loop;
- -- Attribute belongs on the base type. If the view of the type is
- -- currently private, it also belongs on the underlying type.
+ Error_Pragma ("pragma% is not in declarative part or package spec");
+ end Check_Is_In_Decl_Part_Or_Package_Spec;
- Set_Is_Volatile (Base_Type (E));
- Set_Is_Volatile (Underlying_Type (E));
+ -------------------------
+ -- Check_No_Identifier --
+ -------------------------
- Set_Treat_As_Volatile (E);
- Set_Treat_As_Volatile (Underlying_Type (E));
+ procedure Check_No_Identifier (Arg : Node_Id) is
+ begin
+ if Nkind (Arg) = N_Pragma_Argument_Association
+ and then Chars (Arg) /= No_Name
+ then
+ Error_Pragma_Arg_Ident
+ ("pragma% does not permit identifier& here", Arg);
+ end if;
+ end Check_No_Identifier;
- elsif K = N_Object_Declaration
- or else (K = N_Component_Declaration
- and then Original_Record_Component (E) = E)
+ --------------------------
+ -- Check_No_Identifiers --
+ --------------------------
+
+ procedure Check_No_Identifiers is
+ Arg_Node : Node_Id;
+ begin
+ if Arg_Count > 0 then
+ Arg_Node := Arg1;
+ while Present (Arg_Node) loop
+ Check_No_Identifier (Arg_Node);
+ Next (Arg_Node);
+ end loop;
+ end if;
+ end Check_No_Identifiers;
+
+ ------------------------
+ -- Check_No_Link_Name --
+ ------------------------
+
+ procedure Check_No_Link_Name is
+ begin
+ if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
+ Arg4 := Arg3;
+ end if;
+
+ if Present (Arg4) then
+ Error_Pragma_Arg
+ ("Link_Name argument not allowed for Import Intrinsic", Arg4);
+ end if;
+ end Check_No_Link_Name;
+
+ -------------------------------
+ -- Check_Optional_Identifier --
+ -------------------------------
+
+ procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
+ begin
+ if Present (Arg)
+ and then Nkind (Arg) = N_Pragma_Argument_Association
+ and then Chars (Arg) /= No_Name
then
- if Rep_Item_Too_Late (E, N) then
- return;
+ if Chars (Arg) /= Id then
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_Name_2 := Id;
+ Error_Msg_N ("pragma% argument expects identifier%", Arg);
+ raise Pragma_Exit;
end if;
+ end if;
+ end Check_Optional_Identifier;
- if Prag_Id /= Pragma_Volatile then
- Set_Is_Atomic (E);
+ procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
+ begin
+ Name_Buffer (1 .. Id'Length) := Id;
+ Name_Len := Id'Length;
+ Check_Optional_Identifier (Arg, Name_Find);
+ end Check_Optional_Identifier;
- -- If the object declaration has an explicit initialization, a
- -- temporary may have to be created to hold the expression, to
- -- ensure that access to the object remain atomic.
+ --------------------------------------
+ -- Check_Precondition_Postcondition --
+ --------------------------------------
- if Nkind (Parent (E)) = N_Object_Declaration
- and then Present (Expression (Parent (E)))
- then
- Set_Has_Delayed_Freeze (E);
- end if;
+ procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
+ P : Node_Id;
+ PO : Node_Id;
- -- An interesting improvement here. If an object of composite
- -- type X is declared atomic, and the type X isn't, that's a
- -- pity, since it may not have appropriate alignment etc. We
- -- can rescue this in the special case where the object and
- -- type are in the same unit by just setting the type as
- -- atomic, so that the back end will process it as atomic.
+ procedure Chain_PPC (PO : Node_Id);
+ -- If PO is an entry or a [generic] subprogram declaration node, then
+ -- the precondition/postcondition applies to this subprogram and the
+ -- processing for the pragma is completed. Otherwise the pragma is
+ -- misplaced.
- -- Note: we used to do this for elementary types as well,
- -- but that turns out to be a bad idea and can have unwanted
- -- effects, most notably if the type is elementary, the object
- -- a simple component within a record, and both are in a spec:
- -- every object of this type in the entire program will be
- -- treated as atomic, thus incurring a potentially costly
- -- synchronization operation for every access.
+ ---------------
+ -- Chain_PPC --
+ ---------------
- -- Of course it would be best if the back end could just adjust
- -- the alignment etc for the specific object, but that's not
- -- something we are capable of doing at this point.
+ procedure Chain_PPC (PO : Node_Id) is
+ S : Entity_Id;
- Utyp := Underlying_Type (Etype (E));
+ begin
+ if Nkind (PO) = N_Abstract_Subprogram_Declaration then
+ if not From_Aspect_Specification (N) then
+ Error_Pragma
+ ("pragma% cannot be applied to abstract subprogram");
- if Present (Utyp)
- and then Is_Composite_Type (Utyp)
- and then Sloc (E) > No_Location
- and then Sloc (Utyp) > No_Location
- and then
- Get_Source_File_Index (Sloc (E)) =
- Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
- then
- Set_Is_Atomic (Underlying_Type (Etype (E)));
+ elsif Class_Present (N) then
+ null;
+
+ else
+ Error_Pragma
+ ("aspect % requires ''Class for abstract subprogram");
end if;
- end if;
- Set_Is_Volatile (E);
- Set_Treat_As_Volatile (E);
+ -- AI05-0230: The same restriction applies to null procedures. For
+ -- compatibility with earlier uses of the Ada pragma, apply this
+ -- rule only to aspect specifications.
+
+ -- The above discrpency needs documentation. Robert is dubious
+ -- about whether it is a good idea ???
- else
- Error_Pragma_Arg
- ("inappropriate entity for pragma%", Arg1);
- end if;
- end Process_Atomic_Shared_Volatile;
+ elsif Nkind (PO) = N_Subprogram_Declaration
+ and then Nkind (Specification (PO)) = N_Procedure_Specification
+ and then Null_Present (Specification (PO))
+ and then From_Aspect_Specification (N)
+ and then not Class_Present (N)
+ then
+ Error_Pragma
+ ("aspect % requires ''Class for null procedure");
- -------------------------------------------
- -- Process_Compile_Time_Warning_Or_Error --
- -------------------------------------------
+ -- Pre/postconditions are legal on a subprogram body if it is not
+ -- a completion of a declaration. They are also legal on a stub
+ -- with no previous declarations (this is checked when processing
+ -- the corresponding aspects).
- procedure Process_Compile_Time_Warning_Or_Error is
- Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
+ elsif Nkind (PO) = N_Subprogram_Body
+ and then Acts_As_Spec (PO)
+ then
+ null;
- begin
- Check_Arg_Count (2);
- Check_No_Identifiers;
- Check_Arg_Is_Static_Expression (Arg2, Standard_String);
- Analyze_And_Resolve (Arg1x, Standard_Boolean);
+ elsif Nkind (PO) = N_Subprogram_Body_Stub then
+ null;
- if Compile_Time_Known_Value (Arg1x) then
- if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
- declare
- Str : constant String_Id :=
- Strval (Get_Pragma_Arg (Arg2));
- Len : constant Int := String_Length (Str);
- Cont : Boolean;
- Ptr : Nat;
- CC : Char_Code;
- C : Character;
- Cent : constant Entity_Id :=
- Cunit_Entity (Current_Sem_Unit);
+ elsif not Nkind_In (PO, N_Subprogram_Declaration,
+ N_Expression_Function,
+ N_Generic_Subprogram_Declaration,
+ N_Entry_Declaration)
+ then
+ Pragma_Misplaced;
+ end if;
- Force : constant Boolean :=
- Prag_Id = Pragma_Compile_Time_Warning
- and then
- Is_Spec_Name (Unit_Name (Current_Sem_Unit))
- and then (Ekind (Cent) /= E_Package
- or else not In_Private_Part (Cent));
- -- Set True if this is the warning case, and we are in the
- -- visible part of a package spec, or in a subprogram spec,
- -- in which case we want to force the client to see the
- -- warning, even though it is not in the main unit.
+ -- Here if we have [generic] subprogram or entry declaration
- begin
- -- Loop through segments of message separated by line feeds.
- -- We output these segments as separate messages with
- -- continuation marks for all but the first.
+ if Nkind (PO) = N_Entry_Declaration then
+ S := Defining_Entity (PO);
+ else
+ S := Defining_Unit_Name (Specification (PO));
- Cont := False;
- Ptr := 1;
- loop
- Error_Msg_Strlen := 0;
+ if Nkind (S) = N_Defining_Program_Unit_Name then
+ S := Defining_Identifier (S);
+ end if;
+ end if;
- -- Loop to copy characters from argument to error message
- -- string buffer.
+ -- Note: we do not analyze the pragma at this point. Instead we
+ -- delay this analysis until the end of the declarative part in
+ -- which the pragma appears. This implements the required delay
+ -- in this analysis, allowing forward references. The analysis
+ -- happens at the end of Analyze_Declarations.
- loop
- exit when Ptr > Len;
- CC := Get_String_Char (Str, Ptr);
- Ptr := Ptr + 1;
+ -- Chain spec PPC pragma to list for subprogram
- -- Ignore wide chars ??? else store character
+ Add_Contract_Item (N, S);
- if In_Character_Range (CC) then
- C := Get_Character (CC);
- exit when C = ASCII.LF;
- Error_Msg_Strlen := Error_Msg_Strlen + 1;
- Error_Msg_String (Error_Msg_Strlen) := C;
- end if;
- end loop;
+ -- Return indicating spec case
- -- Here with one line ready to go
+ In_Body := False;
+ return;
+ end Chain_PPC;
- Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
+ -- Start of processing for Check_Precondition_Postcondition
- -- If this is a warning in a spec, then we want clients
- -- to see the warning, so mark the message with the
- -- special sequence !! to force the warning. In the case
- -- of a package spec, we do not force this if we are in
- -- the private part of the spec.
+ begin
+ if not Is_List_Member (N) then
+ Pragma_Misplaced;
+ end if;
- if Force then
- if Cont = False then
- Error_Msg_N ("<~!!", Arg1);
- Cont := True;
- else
- Error_Msg_N ("\<~!!", Arg1);
- end if;
+ -- Preanalyze message argument if present. Visibility in this
+ -- argument is established at the point of pragma occurrence.
- -- Error, rather than warning, or in a body, so we do not
- -- need to force visibility for client (error will be
- -- output in any case, and this is the situation in which
- -- we do not want a client to get a warning, since the
- -- warning is in the body or the spec private part).
+ if Arg_Count = 2 then
+ Check_Optional_Identifier (Arg2, Name_Message);
+ Preanalyze_Spec_Expression
+ (Get_Pragma_Arg (Arg2), Standard_String);
+ end if;
- else
- if Cont = False then
- Error_Msg_N ("<~", Arg1);
- Cont := True;
- else
- Error_Msg_N ("\<~", Arg1);
- end if;
- end if;
+ -- For a pragma PPC in the extended main source unit, record enabled
+ -- status in SCO.
- exit when Ptr > Len;
- end loop;
- end;
- end if;
+ if not Is_Ignored (N) and then not Split_PPC (N) then
+ Set_SCO_Pragma_Enabled (Loc);
end if;
- end Process_Compile_Time_Warning_Or_Error;
- ------------------------
- -- Process_Convention --
- ------------------------
+ -- If we are within an inlined body, the legality of the pragma
+ -- has been checked already.
- procedure Process_Convention
- (C : out Convention_Id;
- Ent : out Entity_Id)
- is
- Id : Node_Id;
- E : Entity_Id;
- E1 : Entity_Id;
- Cname : Name_Id;
- Comp_Unit : Unit_Number_Type;
+ if In_Inlined_Body then
+ In_Body := True;
+ return;
+ end if;
- procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
- -- Called if we have more than one Export/Import/Convention pragma.
- -- This is generally illegal, but we have a special case of allowing
- -- Import and Interface to coexist if they specify the convention in
- -- a consistent manner. We are allowed to do this, since Interface is
- -- an implementation defined pragma, and we choose to do it since we
- -- know Rational allows this combination. S is the entity id of the
- -- subprogram in question. This procedure also sets the special flag
- -- Import_Interface_Present in both pragmas in the case where we do
- -- have matching Import and Interface pragmas.
+ -- Search prior declarations
- procedure Set_Convention_From_Pragma (E : Entity_Id);
- -- Set convention in entity E, and also flag that the entity has a
- -- convention pragma. If entity is for a private or incomplete type,
- -- also set convention and flag on underlying type. This procedure
- -- also deals with the special case of C_Pass_By_Copy convention.
+ P := N;
+ while Present (Prev (P)) loop
+ P := Prev (P);
- -------------------------------
- -- Diagnose_Multiple_Pragmas --
- -------------------------------
+ -- If the previous node is a generic subprogram, do not go to to
+ -- the original node, which is the unanalyzed tree: we need to
+ -- attach the pre/postconditions to the analyzed version at this
+ -- point. They get propagated to the original tree when analyzing
+ -- the corresponding body.
- procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
- Pdec : constant Node_Id := Declaration_Node (S);
- Decl : Node_Id;
- Err : Boolean;
+ if Nkind (P) not in N_Generic_Declaration then
+ PO := Original_Node (P);
+ else
+ PO := P;
+ end if;
- function Same_Convention (Decl : Node_Id) return Boolean;
- -- Decl is a pragma node. This function returns True if this
- -- pragma has a first argument that is an identifier with a
- -- Chars field corresponding to the Convention_Id C.
+ -- Skip past prior pragma
- function Same_Name (Decl : Node_Id) return Boolean;
- -- Decl is a pragma node. This function returns True if this
- -- pragma has a second argument that is an identifier with a
- -- Chars field that matches the Chars of the current subprogram.
+ if Nkind (PO) = N_Pragma then
+ null;
- ---------------------
- -- Same_Convention --
- ---------------------
+ -- Skip stuff not coming from source
- function Same_Convention (Decl : Node_Id) return Boolean is
- Arg1 : constant Node_Id :=
- First (Pragma_Argument_Associations (Decl));
+ elsif not Comes_From_Source (PO) then
- begin
- if Present (Arg1) then
- declare
- Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
- begin
- if Nkind (Arg) = N_Identifier
- and then Is_Convention_Name (Chars (Arg))
- and then Get_Convention_Id (Chars (Arg)) = C
- then
- return True;
- end if;
- end;
- end if;
+ -- The condition may apply to a subprogram instantiation
- return False;
- end Same_Convention;
+ if Nkind (PO) = N_Subprogram_Declaration
+ and then Present (Generic_Parent (Specification (PO)))
+ then
+ Chain_PPC (PO);
+ return;
- ---------------
- -- Same_Name --
- ---------------
+ elsif Nkind (PO) = N_Subprogram_Declaration
+ and then In_Instance
+ then
+ Chain_PPC (PO);
+ return;
- function Same_Name (Decl : Node_Id) return Boolean is
- Arg1 : constant Node_Id :=
- First (Pragma_Argument_Associations (Decl));
- Arg2 : Node_Id;
+ -- For all other cases of non source code, do nothing
- begin
- if No (Arg1) then
- return False;
+ else
+ null;
end if;
- Arg2 := Next (Arg1);
+ -- Only remaining possibility is subprogram declaration
- if No (Arg2) then
- return False;
- end if;
+ else
+ Chain_PPC (PO);
+ return;
+ end if;
+ end loop;
- declare
- Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
- begin
- if Nkind (Arg) = N_Identifier
- and then Chars (Arg) = Chars (S)
- then
- return True;
- end if;
- end;
+ -- If we fall through loop, pragma is at start of list, so see if it
+ -- is at the start of declarations of a subprogram body.
- return False;
- end Same_Name;
+ if Nkind (Parent (N)) = N_Subprogram_Body
+ and then List_Containing (N) = Declarations (Parent (N))
+ then
+ if Operating_Mode /= Generate_Code
+ or else Inside_A_Generic
+ then
+ -- Analyze pragma expression for correctness and for ASIS use
- -- Start of processing for Diagnose_Multiple_Pragmas
+ Preanalyze_Assert_Expression
+ (Get_Pragma_Arg (Arg1), Standard_Boolean);
- begin
- Err := True;
+ -- In ASIS mode, for a pragma generated from a source aspect,
+ -- also analyze the original aspect expression.
- -- Definitely give message if we have Convention/Export here
+ if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
+ Preanalyze_Assert_Expression
+ (Expression (Corresponding_Aspect (N)), Standard_Boolean);
+ end if;
+ end if;
- if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
- null;
+ In_Body := True;
+ return;
- -- If we have an Import or Export, scan back from pragma to
- -- find any previous pragma applying to the same procedure.
- -- The scan will be terminated by the start of the list, or
- -- hitting the subprogram declaration. This won't allow one
- -- pragma to appear in the public part and one in the private
- -- part, but that seems very unlikely in practice.
+ -- See if it is in the pragmas after a library level subprogram
- else
- Decl := Prev (N);
- while Present (Decl) and then Decl /= Pdec loop
+ elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then
- -- Look for pragma with same name as us
+ -- In formal verification mode, analyze pragma expression for
+ -- correctness, as it is not expanded later.
- if Nkind (Decl) = N_Pragma
- and then Same_Name (Decl)
- then
- -- Give error if same as our pragma or Export/Convention
+ if Alfa_Mode then
+ Analyze_PPC_In_Decl_Part
+ (N, Defining_Entity (Unit (Parent (Parent (N)))));
+ end if;
- if Nam_In (Pragma_Name (Decl), Name_Export,
- Name_Convention,
- Pragma_Name (N))
- then
- exit;
+ Chain_PPC (Unit (Parent (Parent (N))));
+ return;
+ end if;
- -- Case of Import/Interface or the other way round
+ -- If we fall through, pragma was misplaced
- elsif Nam_In (Pragma_Name (Decl), Name_Interface,
- Name_Import)
- then
- -- Here we know that we have Import and Interface. It
- -- doesn't matter which way round they are. See if
- -- they specify the same convention. If so, all OK,
- -- and set special flags to stop other messages
+ Pragma_Misplaced;
+ end Check_Precondition_Postcondition;
- if Same_Convention (Decl) then
- Set_Import_Interface_Present (N);
- Set_Import_Interface_Present (Decl);
- Err := False;
+ -----------------------------
+ -- Check_Static_Constraint --
+ -----------------------------
- -- If different conventions, special message
+ -- Note: for convenience in writing this procedure, in addition to
+ -- the officially (i.e. by spec) allowed argument which is always a
+ -- constraint, it also allows ranges and discriminant associations.
+ -- Above is not clear ???
- else
- Error_Msg_Sloc := Sloc (Decl);
- Error_Pragma_Arg
- ("convention differs from that given#", Arg1);
- return;
- end if;
- end if;
- end if;
+ procedure Check_Static_Constraint (Constr : Node_Id) is
- Next (Decl);
- end loop;
- end if;
+ procedure Require_Static (E : Node_Id);
+ -- Require given expression to be static expression
- -- Give message if needed if we fall through those tests
- -- except on Relaxed_RM_Semantics where we let go: either this
- -- is a case accepted/ignored by other Ada compilers (e.g.
- -- a mix of Convention and Import), or another error will be
- -- generated later (e.g. using both Import and Export).
+ --------------------
+ -- Require_Static --
+ --------------------
- if Err and not Relaxed_RM_Semantics then
- Error_Pragma_Arg
- ("at most one Convention/Export/Import pragma is allowed",
- Arg2);
+ procedure Require_Static (E : Node_Id) is
+ begin
+ if not Is_OK_Static_Expression (E) then
+ Flag_Non_Static_Expr
+ ("non-static constraint not allowed in Unchecked_Union!", E);
+ raise Pragma_Exit;
end if;
- end Diagnose_Multiple_Pragmas;
+ end Require_Static;
- --------------------------------
- -- Set_Convention_From_Pragma --
- --------------------------------
+ -- Start of processing for Check_Static_Constraint
- procedure Set_Convention_From_Pragma (E : Entity_Id) is
- begin
- -- Ada 2005 (AI-430): Check invalid attempt to change convention
- -- for an overridden dispatching operation. Technically this is
- -- an amendment and should only be done in Ada 2005 mode. However,
- -- this is clearly a mistake, since the problem that is addressed
- -- by this AI is that there is a clear gap in the RM!
+ begin
+ case Nkind (Constr) is
+ when N_Discriminant_Association =>
+ Require_Static (Expression (Constr));
- if Is_Dispatching_Operation (E)
- and then Present (Overridden_Operation (E))
- and then C /= Convention (Overridden_Operation (E))
- then
- Error_Pragma_Arg
- ("cannot change convention for overridden dispatching "
- & "operation", Arg1);
- end if;
+ when N_Range =>
+ Require_Static (Low_Bound (Constr));
+ Require_Static (High_Bound (Constr));
- -- Set the convention
+ when N_Attribute_Reference =>
+ Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
+ Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
- Set_Convention (E, C);
- Set_Has_Convention_Pragma (E);
+ when N_Range_Constraint =>
+ Check_Static_Constraint (Range_Expression (Constr));
- if Is_Incomplete_Or_Private_Type (E)
- and then Present (Underlying_Type (E))
- then
- Set_Convention (Underlying_Type (E), C);
- Set_Has_Convention_Pragma (Underlying_Type (E), True);
- end if;
+ when N_Index_Or_Discriminant_Constraint =>
+ declare
+ IDC : Entity_Id;
+ begin
+ IDC := First (Constraints (Constr));
+ while Present (IDC) loop
+ Check_Static_Constraint (IDC);
+ Next (IDC);
+ end loop;
+ end;
- -- A class-wide type should inherit the convention of the specific
- -- root type (although this isn't specified clearly by the RM).
+ when others =>
+ null;
+ end case;
+ end Check_Static_Constraint;
- if Is_Type (E) and then Present (Class_Wide_Type (E)) then
- Set_Convention (Class_Wide_Type (E), C);
- end if;
+ ---------------------
+ -- Check_Test_Case --
+ ---------------------
- -- If the entity is a record type, then check for special case of
- -- C_Pass_By_Copy, which is treated the same as C except that the
- -- special record flag is set. This convention is only permitted
- -- on record types (see AI95-00131).
+ procedure Check_Test_Case is
+ P : Node_Id;
+ PO : Node_Id;
- if Cname = Name_C_Pass_By_Copy then
- if Is_Record_Type (E) then
- Set_C_Pass_By_Copy (Base_Type (E));
- elsif Is_Incomplete_Or_Private_Type (E)
- and then Is_Record_Type (Underlying_Type (E))
- then
- Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
- else
- Error_Pragma_Arg
- ("C_Pass_By_Copy convention allowed only for record type",
- Arg2);
- end if;
- end if;
+ procedure Chain_CTC (PO : Node_Id);
+ -- If PO is a [generic] subprogram declaration node, then the
+ -- test-case applies to this subprogram and the processing for
+ -- the pragma is completed. Otherwise the pragma is misplaced.
- -- If the entity is a derived boolean type, check for the special
- -- case of convention C, C++, or Fortran, where we consider any
- -- nonzero value to represent true.
+ ---------------
+ -- Chain_CTC --
+ ---------------
- if Is_Discrete_Type (E)
- and then Root_Type (Etype (E)) = Standard_Boolean
- and then
- (C = Convention_C
- or else
- C = Convention_CPP
- or else
- C = Convention_Fortran)
+ procedure Chain_CTC (PO : Node_Id) is
+ S : Entity_Id;
+
+ begin
+ if Nkind (PO) = N_Abstract_Subprogram_Declaration then
+ Error_Pragma
+ ("pragma% cannot be applied to abstract subprogram");
+
+ elsif Nkind (PO) = N_Entry_Declaration then
+ Error_Pragma ("pragma% cannot be applied to entry");
+
+ elsif not Nkind_In (PO, N_Subprogram_Declaration,
+ N_Generic_Subprogram_Declaration)
then
- Set_Nonzero_Is_True (Base_Type (E));
+ Pragma_Misplaced;
end if;
- end Set_Convention_From_Pragma;
- -- Start of processing for Process_Convention
+ -- Here if we have [generic] subprogram declaration
- begin
- Check_At_Least_N_Arguments (2);
- Check_Optional_Identifier (Arg1, Name_Convention);
- Check_Arg_Is_Identifier (Arg1);
- Cname := Chars (Get_Pragma_Arg (Arg1));
+ S := Defining_Unit_Name (Specification (PO));
- -- C_Pass_By_Copy is treated as a synonym for convention C (this is
- -- tested again below to set the critical flag).
+ -- Note: we do not analyze the pragma at this point. Instead we
+ -- delay this analysis until the end of the declarative part in
+ -- which the pragma appears. This implements the required delay
+ -- in this analysis, allowing forward references. The analysis
+ -- happens at the end of Analyze_Declarations.
- if Cname = Name_C_Pass_By_Copy then
- C := Convention_C;
+ -- There should not be another test-case with the same name
+ -- associated to this subprogram.
- -- Otherwise we must have something in the standard convention list
+ declare
+ Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
+ CTC : Node_Id;
- elsif Is_Convention_Name (Cname) then
- C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
+ begin
+ CTC := Contract_Test_Cases (Contract (S));
+ while Present (CTC) loop
- -- In DEC VMS, it seems that there is an undocumented feature that
- -- any unrecognized convention is treated as the default, which for
- -- us is convention C. It does not seem so terrible to do this
- -- unconditionally, silently in the VMS case, and with a warning
- -- in the non-VMS case.
+ -- Omit pragma Contract_Cases because it does not introduce
+ -- a unique case name and it does not follow the syntax of
+ -- Test_Case.
- else
- if Warn_On_Export_Import and not OpenVMS_On_Target then
- Error_Msg_N
- ("??unrecognized convention name, C assumed",
- Get_Pragma_Arg (Arg1));
- end if;
+ if Pragma_Name (CTC) = Name_Contract_Cases then
+ null;
- C := Convention_C;
- end if;
+ elsif String_Equal
+ (Name, Get_Name_From_CTC_Pragma (CTC))
+ then
+ Error_Msg_Sloc := Sloc (CTC);
+ Error_Pragma ("name for pragma% is already used#");
+ end if;
- Check_Optional_Identifier (Arg2, Name_Entity);
- Check_Arg_Is_Local_Name (Arg2);
+ CTC := Next_Pragma (CTC);
+ end loop;
+ end;
- Id := Get_Pragma_Arg (Arg2);
- Analyze (Id);
+ -- Chain spec CTC pragma to list for subprogram
- if not Is_Entity_Name (Id) then
- Error_Pragma_Arg ("entity name required", Arg2);
- end if;
+ Add_Contract_Item (N, S);
+ end Chain_CTC;
- E := Entity (Id);
+ -- Start of processing for Check_Test_Case
- -- Set entity to return
+ begin
+ -- First check pragma arguments
- Ent := E;
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (2);
+ Check_At_Most_N_Arguments (4);
+ Check_Arg_Order
+ ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
- -- Ada_Pass_By_Copy special checking
+ Check_Optional_Identifier (Arg1, Name_Name);
+ Check_Arg_Is_Static_Expression (Arg1, Standard_String);
- if C = Convention_Ada_Pass_By_Copy then
- if not Is_First_Subtype (E) then
- Error_Pragma_Arg
- ("convention `Ada_Pass_By_Copy` only "
- & "allowed for types", Arg2);
- end if;
+ -- In ASIS mode, for a pragma generated from a source aspect, also
+ -- analyze the original aspect expression.
- if Is_By_Reference_Type (E) then
- Error_Pragma_Arg
- ("convention `Ada_Pass_By_Copy` not allowed for "
- & "by-reference type", Arg1);
- end if;
+ if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
+ Check_Expr_Is_Static_Expression
+ (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String);
end if;
- -- Ada_Pass_By_Reference special checking
+ Check_Optional_Identifier (Arg2, Name_Mode);
+ Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
- if C = Convention_Ada_Pass_By_Reference then
- if not Is_First_Subtype (E) then
- Error_Pragma_Arg
- ("convention `Ada_Pass_By_Reference` only "
- & "allowed for types", Arg2);
- end if;
+ if Arg_Count = 4 then
+ Check_Identifier (Arg3, Name_Requires);
+ Check_Identifier (Arg4, Name_Ensures);
- if Is_By_Copy_Type (E) then
- Error_Pragma_Arg
- ("convention `Ada_Pass_By_Reference` not allowed for "
- & "by-copy type", Arg1);
- end if;
+ elsif Arg_Count = 3 then
+ Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
end if;
- -- Go to renamed subprogram if present, since convention applies to
- -- the actual renamed entity, not to the renaming entity. If the
- -- subprogram is inherited, go to parent subprogram.
+ -- Check pragma placement
- if Is_Subprogram (E)
- and then Present (Alias (E))
+ if not Is_List_Member (N) then
+ Pragma_Misplaced;
+ end if;
+
+ -- Test-case should only appear in package spec unit
+
+ if Get_Source_Unit (N) = No_Unit
+ or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
+ N_Package_Declaration,
+ N_Generic_Package_Declaration)
then
- if Nkind (Parent (Declaration_Node (E))) =
- N_Subprogram_Renaming_Declaration
- then
- if Scope (E) /= Scope (Alias (E)) then
- Error_Pragma_Ref
- ("cannot apply pragma% to non-local entity&#", E);
- end if;
+ Pragma_Misplaced;
+ end if;
- E := Alias (E);
+ -- Search prior declarations
- elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
- N_Private_Extension_Declaration)
- and then Scope (E) = Scope (Alias (E))
- then
- E := Alias (E);
+ P := N;
+ while Present (Prev (P)) loop
+ P := Prev (P);
- -- Return the parent subprogram the entity was inherited from
+ -- If the previous node is a generic subprogram, do not go to to
+ -- the original node, which is the unanalyzed tree: we need to
+ -- attach the test-case to the analyzed version at this point.
+ -- They get propagated to the original tree when analyzing the
+ -- corresponding body.
- Ent := E;
+ if Nkind (P) not in N_Generic_Declaration then
+ PO := Original_Node (P);
+ else
+ PO := P;
end if;
- end if;
-
- -- Check that we are not applying this to a specless body
- -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada
- -- compilers.
- if Is_Subprogram (E)
- and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
- and then not Relaxed_RM_Semantics
- then
- Error_Pragma
- ("pragma% requires separate spec and must come before body");
- end if;
+ -- Skip past prior pragma
- -- Check that we are not applying this to a named constant
+ if Nkind (PO) = N_Pragma then
+ null;
- if Ekind_In (E, E_Named_Integer, E_Named_Real) then
- Error_Msg_Name_1 := Pname;
- Error_Msg_N
- ("cannot apply pragma% to named constant!",
- Get_Pragma_Arg (Arg2));
- Error_Pragma_Arg
- ("\supply appropriate type for&!", Arg2);
- end if;
+ -- Skip stuff not coming from source
- if Ekind (E) = E_Enumeration_Literal then
- Error_Pragma ("enumeration literal not allowed for pragma%");
- end if;
+ elsif not Comes_From_Source (PO) then
+ null;
- -- Check for rep item appearing too early or too late
+ -- Only remaining possibility is subprogram declaration. First
+ -- check that it is declared directly in a package declaration.
+ -- This may be either the package declaration for the current unit
+ -- being defined or a local package declaration.
- if Etype (E) = Any_Type
- or else Rep_Item_Too_Early (E, N)
- then
- raise Pragma_Exit;
+ elsif not Present (Parent (Parent (PO)))
+ or else not Present (Parent (Parent (Parent (PO))))
+ or else not Nkind_In (Parent (Parent (PO)),
+ N_Package_Declaration,
+ N_Generic_Package_Declaration)
+ then
+ Pragma_Misplaced;
- elsif Present (Underlying_Type (E)) then
- E := Underlying_Type (E);
- end if;
+ else
+ Chain_CTC (PO);
+ return;
+ end if;
+ end loop;
- if Rep_Item_Too_Late (E, N) then
- raise Pragma_Exit;
- end if;
+ -- If we fall through, pragma was misplaced
- if Has_Convention_Pragma (E) then
- Diagnose_Multiple_Pragmas (E);
+ Pragma_Misplaced;
+ end Check_Test_Case;
- elsif Convention (E) = Convention_Protected
- or else Ekind (Scope (E)) = E_Protected_Type
- then
- Error_Pragma_Arg
- ("a protected operation cannot be given a different convention",
- Arg2);
- end if;
+ --------------------------------------
+ -- Check_Valid_Configuration_Pragma --
+ --------------------------------------
- -- For Intrinsic, a subprogram is required
+ -- A configuration pragma must appear in the context clause of a
+ -- compilation unit, and only other pragmas may precede it. Note that
+ -- the test also allows use in a configuration pragma file.
- if C = Convention_Intrinsic
- and then not Is_Subprogram (E)
- and then not Is_Generic_Subprogram (E)
- then
- Error_Pragma_Arg
- ("second argument of pragma% must be a subprogram", Arg2);
+ procedure Check_Valid_Configuration_Pragma is
+ begin
+ if not Is_Configuration_Pragma then
+ Error_Pragma ("incorrect placement for configuration pragma%");
end if;
+ end Check_Valid_Configuration_Pragma;
- -- Stdcall case
+ -------------------------------------
+ -- Check_Valid_Library_Unit_Pragma --
+ -------------------------------------
- if C = Convention_Stdcall then
+ procedure Check_Valid_Library_Unit_Pragma is
+ Plist : List_Id;
+ Parent_Node : Node_Id;
+ Unit_Name : Entity_Id;
+ Unit_Kind : Node_Kind;
+ Unit_Node : Node_Id;
+ Sindex : Source_File_Index;
- -- A dispatching call is not allowed. A dispatching subprogram
- -- cannot be used to interface to the Win32 API, so in fact this
- -- check does not impose any effective restriction.
+ begin
+ if not Is_List_Member (N) then
+ Pragma_Misplaced;
- if Is_Dispatching_Operation (E) then
+ else
+ Plist := List_Containing (N);
+ Parent_Node := Parent (Plist);
- Error_Pragma
- ("dispatching subprograms cannot use Stdcall convention");
+ if Parent_Node = Empty then
+ Pragma_Misplaced;
- -- Subprogram is allowed, but not a generic subprogram, and not a
- -- dispatching operation.
+ -- Case of pragma appearing after a compilation unit. In this case
+ -- it must have an argument with the corresponding name and must
+ -- be part of the following pragmas of its parent.
- elsif not Is_Subprogram (E)
- and then not Is_Generic_Subprogram (E)
+ elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
+ if Plist /= Pragmas_After (Parent_Node) then
+ Pragma_Misplaced;
- -- A variable is OK
+ elsif Arg_Count = 0 then
+ Error_Pragma
+ ("argument required if outside compilation unit");
- and then Ekind (E) /= E_Variable
+ else
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Unit_Node := Unit (Parent (Parent_Node));
+ Unit_Kind := Nkind (Unit_Node);
- -- An access to subprogram is also allowed
+ Analyze (Get_Pragma_Arg (Arg1));
- and then not
- (Is_Access_Type (E)
- and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
- then
- Error_Pragma_Arg
- ("second argument of pragma% must be subprogram (type)",
- Arg2);
- end if;
- end if;
+ if Unit_Kind = N_Generic_Subprogram_Declaration
+ or else Unit_Kind = N_Subprogram_Declaration
+ then
+ Unit_Name := Defining_Entity (Unit_Node);
- if not Is_Subprogram (E)
- and then not Is_Generic_Subprogram (E)
- then
- Set_Convention_From_Pragma (E);
+ elsif Unit_Kind in N_Generic_Instantiation then
+ Unit_Name := Defining_Entity (Unit_Node);
- if Is_Type (E) then
- Check_First_Subtype (Arg2);
- Set_Convention_From_Pragma (Base_Type (E));
+ else
+ Unit_Name := Cunit_Entity (Current_Sem_Unit);
+ end if;
- -- For subprograms, we must set the convention on the
- -- internally generated directly designated type as well.
+ if Chars (Unit_Name) /=
+ Chars (Entity (Get_Pragma_Arg (Arg1)))
+ then
+ Error_Pragma_Arg
+ ("pragma% argument is not current unit name", Arg1);
+ end if;
- if Ekind (E) = E_Access_Subprogram_Type then
- Set_Convention_From_Pragma (Directly_Designated_Type (E));
+ if Ekind (Unit_Name) = E_Package
+ and then Present (Renamed_Entity (Unit_Name))
+ then
+ Error_Pragma ("pragma% not allowed for renamed package");
+ end if;
end if;
- end if;
- -- For the subprogram case, set proper convention for all homonyms
- -- in same scope and the same declarative part, i.e. the same
- -- compilation unit.
+ -- Pragma appears other than after a compilation unit
- else
- Comp_Unit := Get_Source_Unit (E);
- Set_Convention_From_Pragma (E);
+ else
+ -- Here we check for the generic instantiation case and also
+ -- for the case of processing a generic formal package. We
+ -- detect these cases by noting that the Sloc on the node
+ -- does not belong to the current compilation unit.
- -- Treat a pragma Import as an implicit body, and pragma import
- -- as implicit reference (for navigation in GPS).
+ Sindex := Source_Index (Current_Sem_Unit);
- if Prag_Id = Pragma_Import then
- Generate_Reference (E, Id, 'b');
+ if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
+ Rewrite (N, Make_Null_Statement (Loc));
+ return;
- -- For exported entities we restrict the generation of references
- -- to entities exported to foreign languages since entities
- -- exported to Ada do not provide further information to GPS and
- -- add undesired references to the output of the gnatxref tool.
+ -- If before first declaration, the pragma applies to the
+ -- enclosing unit, and the name if present must be this name.
- elsif Prag_Id = Pragma_Export
- and then Convention (E) /= Convention_Ada
- then
- Generate_Reference (E, Id, 'i');
- end if;
+ elsif Is_Before_First_Decl (N, Plist) then
+ Unit_Node := Unit_Declaration_Node (Current_Scope);
+ Unit_Kind := Nkind (Unit_Node);
- -- If the pragma comes from from an aspect, it only applies
- -- to the given entity, not its homonyms.
+ if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
+ Pragma_Misplaced;
- if From_Aspect_Specification (N) then
- return;
- end if;
+ elsif Unit_Kind = N_Subprogram_Body
+ and then not Acts_As_Spec (Unit_Node)
+ then
+ Pragma_Misplaced;
- -- Otherwise Loop through the homonyms of the pragma argument's
- -- entity, an apply convention to those in the current scope.
+ elsif Nkind (Parent_Node) = N_Package_Body then
+ Pragma_Misplaced;
- E1 := Ent;
+ elsif Nkind (Parent_Node) = N_Package_Specification
+ and then Plist = Private_Declarations (Parent_Node)
+ then
+ Pragma_Misplaced;
- loop
- E1 := Homonym (E1);
- exit when No (E1) or else Scope (E1) /= Current_Scope;
+ elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
+ or else Nkind (Parent_Node) =
+ N_Generic_Subprogram_Declaration)
+ and then Plist = Generic_Formal_Declarations (Parent_Node)
+ then
+ Pragma_Misplaced;
- -- Do not set the pragma on inherited operations or on formal
- -- subprograms.
+ elsif Arg_Count > 0 then
+ Analyze (Get_Pragma_Arg (Arg1));
- if Comes_From_Source (E1)
- and then Comp_Unit = Get_Source_Unit (E1)
- and then not Is_Formal_Subprogram (E1)
- and then Nkind (Original_Node (Parent (E1))) /=
- N_Full_Type_Declaration
- then
- if Present (Alias (E1))
- and then Scope (E1) /= Scope (Alias (E1))
- then
- Error_Pragma_Ref
- ("cannot apply pragma% to non-local entity& declared#",
- E1);
- end if;
+ if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
+ Error_Pragma_Arg
+ ("name in pragma% must be enclosing unit", Arg1);
+ end if;
- Set_Convention_From_Pragma (E1);
+ -- It is legal to have no argument in this context
- if Prag_Id = Pragma_Import then
- Generate_Reference (E1, Id, 'b');
+ else
+ return;
end if;
+
+ -- Error if not before first declaration. This is because a
+ -- library unit pragma argument must be the name of a library
+ -- unit (RM 10.1.5(7)), but the only names permitted in this
+ -- context are (RM 10.1.5(6)) names of subprogram declarations,
+ -- generic subprogram declarations or generic instantiations.
+
+ else
+ Error_Pragma
+ ("pragma% misplaced, must be before first declaration");
end if;
- end loop;
+ end if;
end if;
- end Process_Convention;
+ end Check_Valid_Library_Unit_Pragma;
- ----------------------------------------
- -- Process_Disable_Enable_Atomic_Sync --
- ----------------------------------------
+ -------------------
+ -- Check_Variant --
+ -------------------
+
+ procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
+ Clist : constant Node_Id := Component_List (Variant);
+ Comp : Node_Id;
- procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
begin
- GNAT_Pragma;
- Check_No_Identifiers;
- Check_At_Most_N_Arguments (1);
+ Comp := First (Component_Items (Clist));
+ while Present (Comp) loop
+ Check_Component (Comp, UU_Typ, In_Variant_Part => True);
+ Next (Comp);
+ end loop;
+ end Check_Variant;
- -- Modeled internally as
- -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
+ ------------------
+ -- Error_Pragma --
+ ------------------
- Rewrite (N,
- Make_Pragma (Loc,
- Pragma_Identifier =>
- Make_Identifier (Loc, Nam),
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_Identifier (Loc, Name_Atomic_Synchronization)))));
+ procedure Error_Pragma (Msg : String) is
+ MsgF : String := Msg;
+ begin
+ Error_Msg_Name_1 := Pname;
+ Fix_Error (MsgF);
+ Error_Msg_N (MsgF, N);
+ raise Pragma_Exit;
+ end Error_Pragma;
- if Present (Arg1) then
- Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
- end if;
+ ----------------------
+ -- Error_Pragma_Arg --
+ ----------------------
- Analyze (N);
- end Process_Disable_Enable_Atomic_Sync;
+ procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
+ MsgF : String := Msg;
+ begin
+ Error_Msg_Name_1 := Pname;
+ Fix_Error (MsgF);
+ Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
+ raise Pragma_Exit;
+ end Error_Pragma_Arg;
- -----------------------------------------------------
- -- Process_Extended_Import_Export_Exception_Pragma --
- -----------------------------------------------------
+ procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
+ MsgF : String := Msg1;
+ begin
+ Error_Msg_Name_1 := Pname;
+ Fix_Error (MsgF);
+ Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
+ Error_Pragma_Arg (Msg2, Arg);
+ end Error_Pragma_Arg;
- procedure Process_Extended_Import_Export_Exception_Pragma
- (Arg_Internal : Node_Id;
- Arg_External : Node_Id;
- Arg_Form : Node_Id;
- Arg_Code : Node_Id)
- is
- Def_Id : Entity_Id;
- Code_Val : Uint;
+ ----------------------------
+ -- Error_Pragma_Arg_Ident --
+ ----------------------------
+ procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
+ MsgF : String := Msg;
begin
- if not OpenVMS_On_Target then
- Error_Pragma
- ("??pragma% ignored (applies only to Open'V'M'S)");
- end if;
+ Error_Msg_Name_1 := Pname;
+ Fix_Error (MsgF);
+ Error_Msg_N (MsgF, Arg);
+ raise Pragma_Exit;
+ end Error_Pragma_Arg_Ident;
- Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
- Def_Id := Entity (Arg_Internal);
+ ----------------------
+ -- Error_Pragma_Ref --
+ ----------------------
- if Ekind (Def_Id) /= E_Exception then
- Error_Pragma_Arg
- ("pragma% must refer to declared exception", Arg_Internal);
- end if;
+ procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
+ MsgF : String := Msg;
+ begin
+ Error_Msg_Name_1 := Pname;
+ Fix_Error (MsgF);
+ Error_Msg_Sloc := Sloc (Ref);
+ Error_Msg_NE (MsgF, N, Ref);
+ raise Pragma_Exit;
+ end Error_Pragma_Ref;
- Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
+ ------------------------
+ -- Find_Lib_Unit_Name --
+ ------------------------
- if Present (Arg_Form) then
- Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
- end if;
+ function Find_Lib_Unit_Name return Entity_Id is
+ begin
+ -- Return inner compilation unit entity, for case of nested
+ -- categorization pragmas. This happens in generic unit.
- if Present (Arg_Form)
- and then Chars (Arg_Form) = Name_Ada
+ if Nkind (Parent (N)) = N_Package_Specification
+ and then Defining_Entity (Parent (N)) /= Current_Scope
then
- null;
+ return Defining_Entity (Parent (N));
else
- Set_Is_VMS_Exception (Def_Id);
- Set_Exception_Code (Def_Id, No_Uint);
+ return Current_Scope;
end if;
+ end Find_Lib_Unit_Name;
- if Present (Arg_Code) then
- if not Is_VMS_Exception (Def_Id) then
- Error_Pragma_Arg
- ("Code option for pragma% not allowed for Ada case",
- Arg_Code);
- end if;
-
- Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
- Code_Val := Expr_Value (Arg_Code);
-
- if not UI_Is_In_Int_Range (Code_Val) then
- Error_Pragma_Arg
- ("Code option for pragma% must be in 32-bit range",
- Arg_Code);
-
- else
- Set_Exception_Code (Def_Id, Code_Val);
- end if;
- end if;
- end Process_Extended_Import_Export_Exception_Pragma;
+ ----------------------------
+ -- Find_Program_Unit_Name --
+ ----------------------------
- -------------------------------------------------
- -- Process_Extended_Import_Export_Internal_Arg --
- -------------------------------------------------
+ procedure Find_Program_Unit_Name (Id : Node_Id) is
+ Unit_Name : Entity_Id;
+ Unit_Kind : Node_Kind;
+ P : constant Node_Id := Parent (N);
- procedure Process_Extended_Import_Export_Internal_Arg
- (Arg_Internal : Node_Id := Empty)
- is
begin
- if No (Arg_Internal) then
- Error_Pragma ("Internal parameter required for pragma%");
- end if;
+ if Nkind (P) = N_Compilation_Unit then
+ Unit_Kind := Nkind (Unit (P));
- if Nkind (Arg_Internal) = N_Identifier then
- null;
+ if Unit_Kind = N_Subprogram_Declaration
+ or else Unit_Kind = N_Package_Declaration
+ or else Unit_Kind in N_Generic_Declaration
+ then
+ Unit_Name := Defining_Entity (Unit (P));
- elsif Nkind (Arg_Internal) = N_Operator_Symbol
- and then (Prag_Id = Pragma_Import_Function
- or else
- Prag_Id = Pragma_Export_Function)
- then
- null;
+ if Chars (Id) = Chars (Unit_Name) then
+ Set_Entity (Id, Unit_Name);
+ Set_Etype (Id, Etype (Unit_Name));
+ else
+ Set_Etype (Id, Any_Type);
+ Error_Pragma
+ ("cannot find program unit referenced by pragma%");
+ end if;
+
+ else
+ Set_Etype (Id, Any_Type);
+ Error_Pragma ("pragma% inapplicable to this unit");
+ end if;
else
- Error_Pragma_Arg
- ("wrong form for Internal parameter for pragma%", Arg_Internal);
+ Analyze (Id);
end if;
+ end Find_Program_Unit_Name;
- Check_Arg_Is_Local_Name (Arg_Internal);
- end Process_Extended_Import_Export_Internal_Arg;
-
- --------------------------------------------------
- -- Process_Extended_Import_Export_Object_Pragma --
- --------------------------------------------------
+ -----------------------------------------
+ -- Find_Unique_Parameterless_Procedure --
+ -----------------------------------------
- procedure Process_Extended_Import_Export_Object_Pragma
- (Arg_Internal : Node_Id;
- Arg_External : Node_Id;
- Arg_Size : Node_Id)
+ function Find_Unique_Parameterless_Procedure
+ (Name : Entity_Id;
+ Arg : Node_Id) return Entity_Id
is
- Def_Id : Entity_Id;
+ Proc : Entity_Id := Empty;
begin
- Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
- Def_Id := Entity (Arg_Internal);
+ -- The body of this procedure needs some comments ???
- if not Ekind_In (Def_Id, E_Constant, E_Variable) then
+ if not Is_Entity_Name (Name) then
Error_Pragma_Arg
- ("pragma% must designate an object", Arg_Internal);
- end if;
+ ("argument of pragma% must be entity name", Arg);
- if Has_Rep_Pragma (Def_Id, Name_Common_Object)
- or else
- Has_Rep_Pragma (Def_Id, Name_Psect_Object)
- then
- Error_Pragma_Arg
- ("previous Common/Psect_Object applies, pragma % not permitted",
- Arg_Internal);
- end if;
+ elsif not Is_Overloaded (Name) then
+ Proc := Entity (Name);
- if Rep_Item_Too_Late (Def_Id, N) then
- raise Pragma_Exit;
- end if;
+ if Ekind (Proc) /= E_Procedure
+ or else Present (First_Formal (Proc))
+ then
+ Error_Pragma_Arg
+ ("argument of pragma% must be parameterless procedure", Arg);
+ end if;
- Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
+ else
+ declare
+ Found : Boolean := False;
+ It : Interp;
+ Index : Interp_Index;
- if Present (Arg_Size) then
- Check_Arg_Is_External_Name (Arg_Size);
- end if;
+ begin
+ Get_First_Interp (Name, Index, It);
+ while Present (It.Nam) loop
+ Proc := It.Nam;
- -- Export_Object case
+ if Ekind (Proc) = E_Procedure
+ and then No (First_Formal (Proc))
+ then
+ if not Found then
+ Found := True;
+ Set_Entity (Name, Proc);
+ Set_Is_Overloaded (Name, False);
+ else
+ Error_Pragma_Arg
+ ("ambiguous handler name for pragma% ", Arg);
+ end if;
+ end if;
- if Prag_Id = Pragma_Export_Object then
- if not Is_Library_Level_Entity (Def_Id) then
- Error_Pragma_Arg
- ("argument for pragma% must be library level entity",
- Arg_Internal);
- end if;
+ Get_Next_Interp (Index, It);
+ end loop;
- if Ekind (Current_Scope) = E_Generic_Package then
- Error_Pragma ("pragma& cannot appear in a generic unit");
- end if;
+ if not Found then
+ Error_Pragma_Arg
+ ("argument of pragma% must be parameterless procedure",
+ Arg);
+ else
+ Proc := Entity (Name);
+ end if;
+ end;
+ end if;
- if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
- Error_Pragma_Arg
- ("exported object must have compile time known size",
- Arg_Internal);
- end if;
+ return Proc;
+ end Find_Unique_Parameterless_Procedure;
- if Warn_On_Export_Import and then Is_Exported (Def_Id) then
- Error_Msg_N ("??duplicate Export_Object pragma", N);
- else
- Set_Exported (Def_Id, Arg_Internal);
- end if;
+ ---------------
+ -- Fix_Error --
+ ---------------
- -- Import_Object case
+ procedure Fix_Error (Msg : in out String) is
+ begin
+ -- If we have a rewriting of another pragma, go to that pragma
- else
- if Is_Concurrent_Type (Etype (Def_Id)) then
- Error_Pragma_Arg
- ("cannot use pragma% for task/protected object",
- Arg_Internal);
- end if;
+ if Is_Rewrite_Substitution (N)
+ and then Nkind (Original_Node (N)) = N_Pragma
+ then
+ Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
+ end if;
- if Ekind (Def_Id) = E_Constant then
- Error_Pragma_Arg
- ("cannot import a constant", Arg_Internal);
- end if;
+ -- Case where pragma comes from an aspect specification
- if Warn_On_Export_Import
- and then Has_Discriminants (Etype (Def_Id))
- then
- Error_Msg_N
- ("imported value must be initialized??", Arg_Internal);
- end if;
+ if From_Aspect_Specification (N) then
- if Warn_On_Export_Import
- and then Is_Access_Type (Etype (Def_Id))
- then
- Error_Pragma_Arg
- ("cannot import object of an access type??", Arg_Internal);
- end if;
+ -- Change appearence of "pragma" in message to "aspect"
- if Warn_On_Export_Import
- and then Is_Imported (Def_Id)
- then
- Error_Msg_N ("??duplicate Import_Object pragma", N);
+ for J in Msg'First .. Msg'Last - 5 loop
+ if Msg (J .. J + 5) = "pragma" then
+ Msg (J .. J + 5) := "aspect";
+ end if;
+ end loop;
- -- Check for explicit initialization present. Note that an
- -- initialization generated by the code generator, e.g. for an
- -- access type, does not count here.
+ -- Get name from corresponding aspect
- elsif Present (Expression (Parent (Def_Id)))
- and then
- Comes_From_Source
- (Original_Node (Expression (Parent (Def_Id))))
- then
- Error_Msg_Sloc := Sloc (Def_Id);
- Error_Pragma_Arg
- ("imported entities cannot be initialized (RM B.1(24))",
- "\no initialization allowed for & declared#", Arg1);
- else
- Set_Imported (Def_Id);
- Note_Possible_Modification (Arg_Internal, Sure => False);
- end if;
+ Error_Msg_Name_1 := Original_Name (N);
end if;
- end Process_Extended_Import_Export_Object_Pragma;
+ end Fix_Error;
- ------------------------------------------------------
- -- Process_Extended_Import_Export_Subprogram_Pragma --
- ------------------------------------------------------
+ -------------------------
+ -- Gather_Associations --
+ -------------------------
- procedure Process_Extended_Import_Export_Subprogram_Pragma
- (Arg_Internal : Node_Id;
- Arg_External : Node_Id;
- Arg_Parameter_Types : Node_Id;
- Arg_Result_Type : Node_Id := Empty;
- Arg_Mechanism : Node_Id;
- Arg_Result_Mechanism : Node_Id := Empty;
- Arg_First_Optional_Parameter : Node_Id := Empty)
+ procedure Gather_Associations
+ (Names : Name_List;
+ Args : out Args_List)
is
- Ent : Entity_Id;
- Def_Id : Entity_Id;
- Hom_Id : Entity_Id;
- Formal : Entity_Id;
- Ambiguous : Boolean;
- Match : Boolean;
- Dval : Node_Id;
+ Arg : Node_Id;
- function Same_Base_Type
- (Ptype : Node_Id;
- Formal : Entity_Id) return Boolean;
- -- Determines if Ptype references the type of Formal. Note that only
- -- the base types need to match according to the spec. Ptype here is
- -- the argument from the pragma, which is either a type name, or an
- -- access attribute.
+ begin
+ -- Initialize all parameters to Empty
- --------------------
- -- Same_Base_Type --
- --------------------
+ for J in Args'Range loop
+ Args (J) := Empty;
+ end loop;
- function Same_Base_Type
- (Ptype : Node_Id;
- Formal : Entity_Id) return Boolean
- is
- Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
- Pref : Node_Id;
+ -- That's all we have to do if there are no argument associations
- begin
- -- Case where pragma argument is typ'Access
+ if No (Pragma_Argument_Associations (N)) then
+ return;
+ end if;
- if Nkind (Ptype) = N_Attribute_Reference
- and then Attribute_Name (Ptype) = Name_Access
- then
- Pref := Prefix (Ptype);
- Find_Type (Pref);
+ -- Otherwise first deal with any positional parameters present
- if not Is_Entity_Name (Pref)
- or else Entity (Pref) = Any_Type
- then
- raise Pragma_Exit;
- end if;
+ Arg := First (Pragma_Argument_Associations (N));
+ for Index in Args'Range loop
+ exit when No (Arg) or else Chars (Arg) /= No_Name;
+ Args (Index) := Get_Pragma_Arg (Arg);
+ Next (Arg);
+ end loop;
- -- We have a match if the corresponding argument is of an
- -- anonymous access type, and its designated type matches the
- -- type of the prefix of the access attribute
+ -- Positional parameters all processed, if any left, then we
+ -- have too many positional parameters.
- return Ekind (Ftyp) = E_Anonymous_Access_Type
- and then Base_Type (Entity (Pref)) =
- Base_Type (Etype (Designated_Type (Ftyp)));
+ if Present (Arg) and then Chars (Arg) = No_Name then
+ Error_Pragma_Arg
+ ("too many positional associations for pragma%", Arg);
+ end if;
- -- Case where pragma argument is a type name
+ -- Process named parameters if any are present
+
+ while Present (Arg) loop
+ if Chars (Arg) = No_Name then
+ Error_Pragma_Arg
+ ("positional association cannot follow named association",
+ Arg);
else
- Find_Type (Ptype);
+ for Index in Names'Range loop
+ if Names (Index) = Chars (Arg) then
+ if Present (Args (Index)) then
+ Error_Pragma_Arg
+ ("duplicate argument association for pragma%", Arg);
+ else
+ Args (Index) := Get_Pragma_Arg (Arg);
+ exit;
+ end if;
+ end if;
- if not Is_Entity_Name (Ptype)
- or else Entity (Ptype) = Any_Type
- then
- raise Pragma_Exit;
- end if;
+ if Index = Names'Last then
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N ("pragma% does not allow & argument", Arg);
- -- We have a match if the corresponding argument is of the type
- -- given in the pragma (comparing base types)
+ -- Check for possible misspelling
- return Base_Type (Entity (Ptype)) = Ftyp;
+ for Index1 in Names'Range loop
+ if Is_Bad_Spelling_Of
+ (Chars (Arg), Names (Index1))
+ then
+ Error_Msg_Name_1 := Names (Index1);
+ Error_Msg_N -- CODEFIX
+ ("\possible misspelling of%", Arg);
+ exit;
+ end if;
+ end loop;
+
+ raise Pragma_Exit;
+ end if;
+ end loop;
end if;
- end Same_Base_Type;
- -- Start of processing for
- -- Process_Extended_Import_Export_Subprogram_Pragma
+ Next (Arg);
+ end loop;
+ end Gather_Associations;
+ -----------------
+ -- GNAT_Pragma --
+ -----------------
+
+ procedure GNAT_Pragma is
begin
- Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
- Ent := Empty;
- Ambiguous := False;
+ -- We need to check the No_Implementation_Pragmas restriction for
+ -- the case of a pragma from source. Note that the case of aspects
+ -- generating corresponding pragmas marks these pragmas as not being
+ -- from source, so this test also catches that case.
- -- Loop through homonyms (overloadings) of the entity
+ if Comes_From_Source (N) then
+ Check_Restriction (No_Implementation_Pragmas, N);
+ end if;
+ end GNAT_Pragma;
- Hom_Id := Entity (Arg_Internal);
- while Present (Hom_Id) loop
- Def_Id := Get_Base_Subprogram (Hom_Id);
+ --------------------------
+ -- Is_Before_First_Decl --
+ --------------------------
- -- We need a subprogram in the current scope
+ function Is_Before_First_Decl
+ (Pragma_Node : Node_Id;
+ Decls : List_Id) return Boolean
+ is
+ Item : Node_Id := First (Decls);
- if not Is_Subprogram (Def_Id)
- or else Scope (Def_Id) /= Current_Scope
- then
- null;
+ begin
+ -- Only other pragmas can come before this pragma
- else
- Match := True;
+ loop
+ if No (Item) or else Nkind (Item) /= N_Pragma then
+ return False;
- -- Pragma cannot apply to subprogram body
+ elsif Item = Pragma_Node then
+ return True;
+ end if;
- if Is_Subprogram (Def_Id)
- and then Nkind (Parent (Declaration_Node (Def_Id))) =
- N_Subprogram_Body
- then
- Error_Pragma
- ("pragma% requires separate spec"
- & " and must come before body");
+ Next (Item);
+ end loop;
+ end Is_Before_First_Decl;
+
+ -----------------------------
+ -- Is_Configuration_Pragma --
+ -----------------------------
+
+ -- A configuration pragma must appear in the context clause of a
+ -- compilation unit, and only other pragmas may precede it. Note that
+ -- the test below also permits use in a configuration pragma file.
+
+ function Is_Configuration_Pragma return Boolean is
+ Lis : constant List_Id := List_Containing (N);
+ Par : constant Node_Id := Parent (N);
+ Prg : Node_Id;
+
+ begin
+ -- If no parent, then we are in the configuration pragma file,
+ -- so the placement is definitely appropriate.
+
+ if No (Par) then
+ return True;
+
+ -- Otherwise we must be in the context clause of a compilation unit
+ -- and the only thing allowed before us in the context list is more
+ -- configuration pragmas.
+
+ elsif Nkind (Par) = N_Compilation_Unit
+ and then Context_Items (Par) = Lis
+ then
+ Prg := First (Lis);
+
+ loop
+ if Prg = N then
+ return True;
+ elsif Nkind (Prg) /= N_Pragma then
+ return False;
end if;
- -- Test result type if given, note that the result type
- -- parameter can only be present for the function cases.
+ Next (Prg);
+ end loop;
- if Present (Arg_Result_Type)
- and then not Same_Base_Type (Arg_Result_Type, Def_Id)
- then
- Match := False;
+ else
+ return False;
+ end if;
+ end Is_Configuration_Pragma;
- elsif Etype (Def_Id) /= Standard_Void_Type
- and then
- Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
- then
- Match := False;
+ --------------------------
+ -- Is_In_Context_Clause --
+ --------------------------
- -- Test parameter types if given. Note that this parameter
- -- has not been analyzed (and must not be, since it is
- -- semantic nonsense), so we get it as the parser left it.
+ function Is_In_Context_Clause return Boolean is
+ Plist : List_Id;
+ Parent_Node : Node_Id;
- elsif Present (Arg_Parameter_Types) then
- Check_Matching_Types : declare
- Formal : Entity_Id;
- Ptype : Node_Id;
+ begin
+ if not Is_List_Member (N) then
+ return False;
- begin
- Formal := First_Formal (Def_Id);
+ else
+ Plist := List_Containing (N);
+ Parent_Node := Parent (Plist);
- if Nkind (Arg_Parameter_Types) = N_Null then
- if Present (Formal) then
- Match := False;
- end if;
+ if Parent_Node = Empty
+ or else Nkind (Parent_Node) /= N_Compilation_Unit
+ or else Context_Items (Parent_Node) /= Plist
+ then
+ return False;
+ end if;
+ end if;
- -- A list of one type, e.g. (List) is parsed as
- -- a parenthesized expression.
+ return True;
+ end Is_In_Context_Clause;
- elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
- and then Paren_Count (Arg_Parameter_Types) = 1
- then
- if No (Formal)
- or else Present (Next_Formal (Formal))
- then
- Match := False;
- else
- Match :=
- Same_Base_Type (Arg_Parameter_Types, Formal);
- end if;
+ ---------------------------------
+ -- Is_Static_String_Expression --
+ ---------------------------------
- -- A list of more than one type is parsed as a aggregate
+ function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
- elsif Nkind (Arg_Parameter_Types) = N_Aggregate
- and then Paren_Count (Arg_Parameter_Types) = 0
- then
- Ptype := First (Expressions (Arg_Parameter_Types));
- while Present (Ptype) or else Present (Formal) loop
- if No (Ptype)
- or else No (Formal)
- or else not Same_Base_Type (Ptype, Formal)
- then
- Match := False;
- exit;
- else
- Next_Formal (Formal);
- Next (Ptype);
- end if;
- end loop;
+ begin
+ Analyze_And_Resolve (Argx);
+ return Is_OK_Static_Expression (Argx)
+ and then Nkind (Argx) = N_String_Literal;
+ end Is_Static_String_Expression;
- -- Anything else is of the wrong form
+ ----------------------
+ -- Pragma_Misplaced --
+ ----------------------
- else
- Error_Pragma_Arg
- ("wrong form for Parameter_Types parameter",
- Arg_Parameter_Types);
- end if;
- end Check_Matching_Types;
- end if;
+ procedure Pragma_Misplaced is
+ begin
+ Error_Pragma ("incorrect placement of pragma%");
+ end Pragma_Misplaced;
- -- Match is now False if the entry we found did not match
- -- either a supplied Parameter_Types or Result_Types argument
+ ------------------------------------
+ -- Process_Atomic_Shared_Volatile --
+ ------------------------------------
- if Match then
- if No (Ent) then
- Ent := Def_Id;
+ procedure Process_Atomic_Shared_Volatile is
+ E_Id : Node_Id;
+ E : Entity_Id;
+ D : Node_Id;
+ K : Node_Kind;
+ Utyp : Entity_Id;
- -- Ambiguous case, the flag Ambiguous shows if we already
- -- detected this and output the initial messages.
+ procedure Set_Atomic (E : Entity_Id);
+ -- Set given type as atomic, and if no explicit alignment was given,
+ -- set alignment to unknown, since back end knows what the alignment
+ -- requirements are for atomic arrays. Note: this step is necessary
+ -- for derived types.
- else
- if not Ambiguous then
- Ambiguous := True;
- Error_Msg_Name_1 := Pname;
- Error_Msg_N
- ("pragma% does not uniquely identify subprogram!",
- N);
- Error_Msg_Sloc := Sloc (Ent);
- Error_Msg_N ("matching subprogram #!", N);
- Ent := Empty;
- end if;
+ ----------------
+ -- Set_Atomic --
+ ----------------
- Error_Msg_Sloc := Sloc (Def_Id);
- Error_Msg_N ("matching subprogram #!", N);
- end if;
- end if;
- end if;
+ procedure Set_Atomic (E : Entity_Id) is
+ begin
+ Set_Is_Atomic (E);
- Hom_Id := Homonym (Hom_Id);
- end loop;
+ if not Has_Alignment_Clause (E) then
+ Set_Alignment (E, Uint_0);
+ end if;
+ end Set_Atomic;
- -- See if we found an entry
+ -- Start of processing for Process_Atomic_Shared_Volatile
- if No (Ent) then
- if not Ambiguous then
- if Is_Generic_Subprogram (Entity (Arg_Internal)) then
- Error_Pragma
- ("pragma% cannot be given for generic subprogram");
- else
- Error_Pragma
- ("pragma% does not identify local subprogram");
- end if;
- end if;
+ begin
+ Check_Ada_83_Warning;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
+ if Etype (E_Id) = Any_Type then
return;
end if;
- -- Import pragmas must be for imported entities
-
- if Prag_Id = Pragma_Import_Function
- or else
- Prag_Id = Pragma_Import_Procedure
- or else
- Prag_Id = Pragma_Import_Valued_Procedure
- then
- if not Is_Imported (Ent) then
- Error_Pragma
- ("pragma Import or Interface must precede pragma%");
- end if;
-
- -- Here we have the Export case which can set the entity as exported
+ E := Entity (E_Id);
+ D := Declaration_Node (E);
+ K := Nkind (D);
- -- But does not do so if the specified external name is null, since
- -- that is taken as a signal in DEC Ada 83 (with which we want to be
- -- compatible) to request no external name.
+ -- Check duplicate before we chain ourselves!
- elsif Nkind (Arg_External) = N_String_Literal
- and then String_Length (Strval (Arg_External)) = 0
- then
- null;
+ Check_Duplicate_Pragma (E);
- -- In all other cases, set entity as exported
+ -- Now check appropriateness of the entity
- else
- Set_Exported (Ent, Arg_Internal);
- end if;
+ if Is_Type (E) then
+ if Rep_Item_Too_Early (E, N)
+ or else
+ Rep_Item_Too_Late (E, N)
+ then
+ return;
+ else
+ Check_First_Subtype (Arg1);
+ end if;
- -- Special processing for Valued_Procedure cases
+ if Prag_Id /= Pragma_Volatile then
+ Set_Atomic (E);
+ Set_Atomic (Underlying_Type (E));
+ Set_Atomic (Base_Type (E));
+ end if;
- if Prag_Id = Pragma_Import_Valued_Procedure
- or else
- Prag_Id = Pragma_Export_Valued_Procedure
- then
- Formal := First_Formal (Ent);
+ -- Attribute belongs on the base type. If the view of the type is
+ -- currently private, it also belongs on the underlying type.
- if No (Formal) then
- Error_Pragma ("at least one parameter required for pragma%");
+ Set_Is_Volatile (Base_Type (E));
+ Set_Is_Volatile (Underlying_Type (E));
- elsif Ekind (Formal) /= E_Out_Parameter then
- Error_Pragma ("first parameter must have mode out for pragma%");
+ Set_Treat_As_Volatile (E);
+ Set_Treat_As_Volatile (Underlying_Type (E));
- else
- Set_Is_Valued_Procedure (Ent);
+ elsif K = N_Object_Declaration
+ or else (K = N_Component_Declaration
+ and then Original_Record_Component (E) = E)
+ then
+ if Rep_Item_Too_Late (E, N) then
+ return;
end if;
- end if;
- Set_Extended_Import_Export_External_Name (Ent, Arg_External);
+ if Prag_Id /= Pragma_Volatile then
+ Set_Is_Atomic (E);
+
+ -- If the object declaration has an explicit initialization, a
+ -- temporary may have to be created to hold the expression, to
+ -- ensure that access to the object remain atomic.
- -- Process Result_Mechanism argument if present. We have already
- -- checked that this is only allowed for the function case.
+ if Nkind (Parent (E)) = N_Object_Declaration
+ and then Present (Expression (Parent (E)))
+ then
+ Set_Has_Delayed_Freeze (E);
+ end if;
- if Present (Arg_Result_Mechanism) then
- Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
- end if;
+ -- An interesting improvement here. If an object of composite
+ -- type X is declared atomic, and the type X isn't, that's a
+ -- pity, since it may not have appropriate alignment etc. We
+ -- can rescue this in the special case where the object and
+ -- type are in the same unit by just setting the type as
+ -- atomic, so that the back end will process it as atomic.
- -- Process Mechanism parameter if present. Note that this parameter
- -- is not analyzed, and must not be analyzed since it is semantic
- -- nonsense, so we get it in exactly as the parser left it.
+ -- Note: we used to do this for elementary types as well,
+ -- but that turns out to be a bad idea and can have unwanted
+ -- effects, most notably if the type is elementary, the object
+ -- a simple component within a record, and both are in a spec:
+ -- every object of this type in the entire program will be
+ -- treated as atomic, thus incurring a potentially costly
+ -- synchronization operation for every access.
- if Present (Arg_Mechanism) then
- declare
- Formal : Entity_Id;
- Massoc : Node_Id;
- Mname : Node_Id;
- Choice : Node_Id;
+ -- Of course it would be best if the back end could just adjust
+ -- the alignment etc for the specific object, but that's not
+ -- something we are capable of doing at this point.
- begin
- -- A single mechanism association without a formal parameter
- -- name is parsed as a parenthesized expression. All other
- -- cases are parsed as aggregates, so we rewrite the single
- -- parameter case as an aggregate for consistency.
+ Utyp := Underlying_Type (Etype (E));
- if Nkind (Arg_Mechanism) /= N_Aggregate
- and then Paren_Count (Arg_Mechanism) = 1
+ if Present (Utyp)
+ and then Is_Composite_Type (Utyp)
+ and then Sloc (E) > No_Location
+ and then Sloc (Utyp) > No_Location
+ and then
+ Get_Source_File_Index (Sloc (E)) =
+ Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
then
- Rewrite (Arg_Mechanism,
- Make_Aggregate (Sloc (Arg_Mechanism),
- Expressions => New_List (
- Relocate_Node (Arg_Mechanism))));
+ Set_Is_Atomic (Underlying_Type (Etype (E)));
end if;
+ end if;
- -- Case of only mechanism name given, applies to all formals
+ Set_Is_Volatile (E);
+ Set_Treat_As_Volatile (E);
- if Nkind (Arg_Mechanism) /= N_Aggregate then
- Formal := First_Formal (Ent);
- while Present (Formal) loop
- Set_Mechanism_Value (Formal, Arg_Mechanism);
- Next_Formal (Formal);
- end loop;
+ else
+ Error_Pragma_Arg
+ ("inappropriate entity for pragma%", Arg1);
+ end if;
+ end Process_Atomic_Shared_Volatile;
- -- Case of list of mechanism associations given
+ -------------------------------------------
+ -- Process_Compile_Time_Warning_Or_Error --
+ -------------------------------------------
- else
- if Null_Record_Present (Arg_Mechanism) then
- Error_Pragma_Arg
- ("inappropriate form for Mechanism parameter",
- Arg_Mechanism);
- end if;
+ procedure Process_Compile_Time_Warning_Or_Error is
+ Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
- -- Deal with positional ones first
+ begin
+ Check_Arg_Count (2);
+ Check_No_Identifiers;
+ Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+ Analyze_And_Resolve (Arg1x, Standard_Boolean);
- Formal := First_Formal (Ent);
+ if Compile_Time_Known_Value (Arg1x) then
+ if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
+ declare
+ Str : constant String_Id :=
+ Strval (Get_Pragma_Arg (Arg2));
+ Len : constant Int := String_Length (Str);
+ Cont : Boolean;
+ Ptr : Nat;
+ CC : Char_Code;
+ C : Character;
+ Cent : constant Entity_Id :=
+ Cunit_Entity (Current_Sem_Unit);
- if Present (Expressions (Arg_Mechanism)) then
- Mname := First (Expressions (Arg_Mechanism));
- while Present (Mname) loop
- if No (Formal) then
- Error_Pragma_Arg
- ("too many mechanism associations", Mname);
- end if;
+ Force : constant Boolean :=
+ Prag_Id = Pragma_Compile_Time_Warning
+ and then
+ Is_Spec_Name (Unit_Name (Current_Sem_Unit))
+ and then (Ekind (Cent) /= E_Package
+ or else not In_Private_Part (Cent));
+ -- Set True if this is the warning case, and we are in the
+ -- visible part of a package spec, or in a subprogram spec,
+ -- in which case we want to force the client to see the
+ -- warning, even though it is not in the main unit.
- Set_Mechanism_Value (Formal, Mname);
- Next_Formal (Formal);
- Next (Mname);
- end loop;
- end if;
+ begin
+ -- Loop through segments of message separated by line feeds.
+ -- We output these segments as separate messages with
+ -- continuation marks for all but the first.
- -- Deal with named entries
+ Cont := False;
+ Ptr := 1;
+ loop
+ Error_Msg_Strlen := 0;
- if Present (Component_Associations (Arg_Mechanism)) then
- Massoc := First (Component_Associations (Arg_Mechanism));
- while Present (Massoc) loop
- Choice := First (Choices (Massoc));
+ -- Loop to copy characters from argument to error message
+ -- string buffer.
- if Nkind (Choice) /= N_Identifier
- or else Present (Next (Choice))
- then
- Error_Pragma_Arg
- ("incorrect form for mechanism association",
- Massoc);
- end if;
+ loop
+ exit when Ptr > Len;
+ CC := Get_String_Char (Str, Ptr);
+ Ptr := Ptr + 1;
- Formal := First_Formal (Ent);
- loop
- if No (Formal) then
- Error_Pragma_Arg
- ("parameter name & not present", Choice);
- end if;
+ -- Ignore wide chars ??? else store character
- if Chars (Choice) = Chars (Formal) then
- Set_Mechanism_Value
- (Formal, Expression (Massoc));
+ if In_Character_Range (CC) then
+ C := Get_Character (CC);
+ exit when C = ASCII.LF;
+ Error_Msg_Strlen := Error_Msg_Strlen + 1;
+ Error_Msg_String (Error_Msg_Strlen) := C;
+ end if;
+ end loop;
- -- Set entity on identifier (needed by ASIS)
+ -- Here with one line ready to go
- Set_Entity (Choice, Formal);
+ Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
- exit;
- end if;
+ -- If this is a warning in a spec, then we want clients
+ -- to see the warning, so mark the message with the
+ -- special sequence !! to force the warning. In the case
+ -- of a package spec, we do not force this if we are in
+ -- the private part of the spec.
- Next_Formal (Formal);
- end loop;
+ if Force then
+ if Cont = False then
+ Error_Msg_N ("<~!!", Arg1);
+ Cont := True;
+ else
+ Error_Msg_N ("\<~!!", Arg1);
+ end if;
- Next (Massoc);
- end loop;
- end if;
- end if;
- end;
- end if;
+ -- Error, rather than warning, or in a body, so we do not
+ -- need to force visibility for client (error will be
+ -- output in any case, and this is the situation in which
+ -- we do not want a client to get a warning, since the
+ -- warning is in the body or the spec private part).
- -- Process First_Optional_Parameter argument if present. We have
- -- already checked that this is only allowed for the Import case.
+ else
+ if Cont = False then
+ Error_Msg_N ("<~", Arg1);
+ Cont := True;
+ else
+ Error_Msg_N ("\<~", Arg1);
+ end if;
+ end if;
- if Present (Arg_First_Optional_Parameter) then
- if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
- Error_Pragma_Arg
- ("first optional parameter must be formal parameter name",
- Arg_First_Optional_Parameter);
+ exit when Ptr > Len;
+ end loop;
+ end;
end if;
+ end if;
+ end Process_Compile_Time_Warning_Or_Error;
- Formal := First_Formal (Ent);
- loop
- if No (Formal) then
- Error_Pragma_Arg
- ("specified formal parameter& not found",
- Arg_First_Optional_Parameter);
- end if;
-
- exit when Chars (Formal) =
- Chars (Arg_First_Optional_Parameter);
-
- Next_Formal (Formal);
- end loop;
+ ------------------------
+ -- Process_Convention --
+ ------------------------
- Set_First_Optional_Parameter (Ent, Formal);
+ procedure Process_Convention
+ (C : out Convention_Id;
+ Ent : out Entity_Id)
+ is
+ Id : Node_Id;
+ E : Entity_Id;
+ E1 : Entity_Id;
+ Cname : Name_Id;
+ Comp_Unit : Unit_Number_Type;
- -- Check specified and all remaining formals have right form
+ procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
+ -- Called if we have more than one Export/Import/Convention pragma.
+ -- This is generally illegal, but we have a special case of allowing
+ -- Import and Interface to coexist if they specify the convention in
+ -- a consistent manner. We are allowed to do this, since Interface is
+ -- an implementation defined pragma, and we choose to do it since we
+ -- know Rational allows this combination. S is the entity id of the
+ -- subprogram in question. This procedure also sets the special flag
+ -- Import_Interface_Present in both pragmas in the case where we do
+ -- have matching Import and Interface pragmas.
- while Present (Formal) loop
- if Ekind (Formal) /= E_In_Parameter then
- Error_Msg_NE
- ("optional formal& is not of mode in!",
- Arg_First_Optional_Parameter, Formal);
+ procedure Set_Convention_From_Pragma (E : Entity_Id);
+ -- Set convention in entity E, and also flag that the entity has a
+ -- convention pragma. If entity is for a private or incomplete type,
+ -- also set convention and flag on underlying type. This procedure
+ -- also deals with the special case of C_Pass_By_Copy convention.
- else
- Dval := Default_Value (Formal);
+ -------------------------------
+ -- Diagnose_Multiple_Pragmas --
+ -------------------------------
- if No (Dval) then
- Error_Msg_NE
- ("optional formal& does not have default value!",
- Arg_First_Optional_Parameter, Formal);
+ procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
+ Pdec : constant Node_Id := Declaration_Node (S);
+ Decl : Node_Id;
+ Err : Boolean;
- elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
- null;
+ function Same_Convention (Decl : Node_Id) return Boolean;
+ -- Decl is a pragma node. This function returns True if this
+ -- pragma has a first argument that is an identifier with a
+ -- Chars field corresponding to the Convention_Id C.
- else
- Error_Msg_FE
- ("default value for optional formal& is non-static!",
- Arg_First_Optional_Parameter, Formal);
- end if;
- end if;
+ function Same_Name (Decl : Node_Id) return Boolean;
+ -- Decl is a pragma node. This function returns True if this
+ -- pragma has a second argument that is an identifier with a
+ -- Chars field that matches the Chars of the current subprogram.
- Set_Is_Optional_Parameter (Formal);
- Next_Formal (Formal);
- end loop;
- end if;
- end Process_Extended_Import_Export_Subprogram_Pragma;
+ ---------------------
+ -- Same_Convention --
+ ---------------------
- --------------------------
- -- Process_Generic_List --
- --------------------------
+ function Same_Convention (Decl : Node_Id) return Boolean is
+ Arg1 : constant Node_Id :=
+ First (Pragma_Argument_Associations (Decl));
- procedure Process_Generic_List is
- Arg : Node_Id;
- Exp : Node_Id;
+ begin
+ if Present (Arg1) then
+ declare
+ Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
+ begin
+ if Nkind (Arg) = N_Identifier
+ and then Is_Convention_Name (Chars (Arg))
+ and then Get_Convention_Id (Chars (Arg)) = C
+ then
+ return True;
+ end if;
+ end;
+ end if;
- begin
- Check_No_Identifiers;
- Check_At_Least_N_Arguments (1);
+ return False;
+ end Same_Convention;
- Arg := Arg1;
- while Present (Arg) loop
- Exp := Get_Pragma_Arg (Arg);
- Analyze (Exp);
+ ---------------
+ -- Same_Name --
+ ---------------
- if not Is_Entity_Name (Exp)
- or else
- (not Is_Generic_Instance (Entity (Exp))
- and then
- not Is_Generic_Unit (Entity (Exp)))
- then
- Error_Pragma_Arg
- ("pragma% argument must be name of generic unit/instance",
- Arg);
- end if;
+ function Same_Name (Decl : Node_Id) return Boolean is
+ Arg1 : constant Node_Id :=
+ First (Pragma_Argument_Associations (Decl));
+ Arg2 : Node_Id;
- Next (Arg);
- end loop;
- end Process_Generic_List;
+ begin
+ if No (Arg1) then
+ return False;
+ end if;
- ------------------------------------
- -- Process_Import_Predefined_Type --
- ------------------------------------
+ Arg2 := Next (Arg1);
- procedure Process_Import_Predefined_Type is
- Loc : constant Source_Ptr := Sloc (N);
- Elmt : Elmt_Id;
- Ftyp : Node_Id := Empty;
- Decl : Node_Id;
- Def : Node_Id;
- Nam : Name_Id;
+ if No (Arg2) then
+ return False;
+ end if;
- begin
- String_To_Name_Buffer (Strval (Expression (Arg3)));
- Nam := Name_Find;
+ declare
+ Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
+ begin
+ if Nkind (Arg) = N_Identifier
+ and then Chars (Arg) = Chars (S)
+ then
+ return True;
+ end if;
+ end;
- Elmt := First_Elmt (Predefined_Float_Types);
- while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
- Next_Elmt (Elmt);
- end loop;
+ return False;
+ end Same_Name;
- Ftyp := Node (Elmt);
+ -- Start of processing for Diagnose_Multiple_Pragmas
- if Present (Ftyp) then
+ begin
+ Err := True;
- -- Don't build a derived type declaration, because predefined C
- -- types have no declaration anywhere, so cannot really be named.
- -- Instead build a full type declaration, starting with an
- -- appropriate type definition is built
+ -- Definitely give message if we have Convention/Export here
- if Is_Floating_Point_Type (Ftyp) then
- Def := Make_Floating_Point_Definition (Loc,
- Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
- Make_Real_Range_Specification (Loc,
- Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
- Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
+ if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
+ null;
- -- Should never have a predefined type we cannot handle
+ -- If we have an Import or Export, scan back from pragma to
+ -- find any previous pragma applying to the same procedure.
+ -- The scan will be terminated by the start of the list, or
+ -- hitting the subprogram declaration. This won't allow one
+ -- pragma to appear in the public part and one in the private
+ -- part, but that seems very unlikely in practice.
else
- raise Program_Error;
- end if;
+ Decl := Prev (N);
+ while Present (Decl) and then Decl /= Pdec loop
- -- Build and insert a Full_Type_Declaration, which will be
- -- analyzed as soon as this list entry has been analyzed.
+ -- Look for pragma with same name as us
- Decl := Make_Full_Type_Declaration (Loc,
- Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
- Type_Definition => Def);
+ if Nkind (Decl) = N_Pragma
+ and then Same_Name (Decl)
+ then
+ -- Give error if same as our pragma or Export/Convention
- Insert_After (N, Decl);
- Mark_Rewrite_Insertion (Decl);
+ if Nam_In (Pragma_Name (Decl), Name_Export,
+ Name_Convention,
+ Pragma_Name (N))
+ then
+ exit;
- else
- Error_Pragma_Arg ("no matching type found for pragma%",
- Arg2);
- end if;
- end Process_Import_Predefined_Type;
+ -- Case of Import/Interface or the other way round
- ---------------------------------
- -- Process_Import_Or_Interface --
- ---------------------------------
+ elsif Nam_In (Pragma_Name (Decl), Name_Interface,
+ Name_Import)
+ then
+ -- Here we know that we have Import and Interface. It
+ -- doesn't matter which way round they are. See if
+ -- they specify the same convention. If so, all OK,
+ -- and set special flags to stop other messages
- procedure Process_Import_Or_Interface is
- C : Convention_Id;
- Def_Id : Entity_Id;
- Hom_Id : Entity_Id;
+ if Same_Convention (Decl) then
+ Set_Import_Interface_Present (N);
+ Set_Import_Interface_Present (Decl);
+ Err := False;
- begin
- Process_Convention (C, Def_Id);
- Kill_Size_Check_Code (Def_Id);
- Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
+ -- If different conventions, special message
- if Ekind_In (Def_Id, E_Variable, E_Constant) then
+ else
+ Error_Msg_Sloc := Sloc (Decl);
+ Error_Pragma_Arg
+ ("convention differs from that given#", Arg1);
+ return;
+ end if;
+ end if;
+ end if;
- -- We do not permit Import to apply to a renaming declaration
+ Next (Decl);
+ end loop;
+ end if;
- if Present (Renamed_Object (Def_Id)) then
+ -- Give message if needed if we fall through those tests
+ -- except on Relaxed_RM_Semantics where we let go: either this
+ -- is a case accepted/ignored by other Ada compilers (e.g.
+ -- a mix of Convention and Import), or another error will be
+ -- generated later (e.g. using both Import and Export).
+
+ if Err and not Relaxed_RM_Semantics then
Error_Pragma_Arg
- ("pragma% not allowed for object renaming", Arg2);
+ ("at most one Convention/Export/Import pragma is allowed",
+ Arg2);
+ end if;
+ end Diagnose_Multiple_Pragmas;
- -- User initialization is not allowed for imported object, but
- -- the object declaration may contain a default initialization,
- -- that will be discarded. Note that an explicit initialization
- -- only counts if it comes from source, otherwise it is simply
- -- the code generator making an implicit initialization explicit.
+ --------------------------------
+ -- Set_Convention_From_Pragma --
+ --------------------------------
- elsif Present (Expression (Parent (Def_Id)))
- and then Comes_From_Source (Expression (Parent (Def_Id)))
+ procedure Set_Convention_From_Pragma (E : Entity_Id) is
+ begin
+ -- Ada 2005 (AI-430): Check invalid attempt to change convention
+ -- for an overridden dispatching operation. Technically this is
+ -- an amendment and should only be done in Ada 2005 mode. However,
+ -- this is clearly a mistake, since the problem that is addressed
+ -- by this AI is that there is a clear gap in the RM!
+
+ if Is_Dispatching_Operation (E)
+ and then Present (Overridden_Operation (E))
+ and then C /= Convention (Overridden_Operation (E))
then
- Error_Msg_Sloc := Sloc (Def_Id);
Error_Pragma_Arg
- ("no initialization allowed for declaration of& #",
- "\imported entities cannot be initialized (RM B.1(24))",
- Arg2);
+ ("cannot change convention for overridden dispatching "
+ & "operation", Arg1);
+ end if;
- else
- Set_Imported (Def_Id);
- Process_Interface_Name (Def_Id, Arg3, Arg4);
+ -- Set the convention
- -- Note that we do not set Is_Public here. That's because we
- -- only want to set it if there is no address clause, and we
- -- don't know that yet, so we delay that processing till
- -- freeze time.
+ Set_Convention (E, C);
+ Set_Has_Convention_Pragma (E);
- -- pragma Import completes deferred constants
+ if Is_Incomplete_Or_Private_Type (E)
+ and then Present (Underlying_Type (E))
+ then
+ Set_Convention (Underlying_Type (E), C);
+ Set_Has_Convention_Pragma (Underlying_Type (E), True);
+ end if;
- if Ekind (Def_Id) = E_Constant then
- Set_Has_Completion (Def_Id);
- end if;
+ -- A class-wide type should inherit the convention of the specific
+ -- root type (although this isn't specified clearly by the RM).
- -- It is not possible to import a constant of an unconstrained
- -- array type (e.g. string) because there is no simple way to
- -- write a meaningful subtype for it.
+ if Is_Type (E) and then Present (Class_Wide_Type (E)) then
+ Set_Convention (Class_Wide_Type (E), C);
+ end if;
- if Is_Array_Type (Etype (Def_Id))
- and then not Is_Constrained (Etype (Def_Id))
+ -- If the entity is a record type, then check for special case of
+ -- C_Pass_By_Copy, which is treated the same as C except that the
+ -- special record flag is set. This convention is only permitted
+ -- on record types (see AI95-00131).
+
+ if Cname = Name_C_Pass_By_Copy then
+ if Is_Record_Type (E) then
+ Set_C_Pass_By_Copy (Base_Type (E));
+ elsif Is_Incomplete_Or_Private_Type (E)
+ and then Is_Record_Type (Underlying_Type (E))
then
- Error_Msg_NE
- ("imported constant& must have a constrained subtype",
- N, Def_Id);
+ Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
+ else
+ Error_Pragma_Arg
+ ("C_Pass_By_Copy convention allowed only for record type",
+ Arg2);
end if;
end if;
- elsif Is_Subprogram (Def_Id)
- or else Is_Generic_Subprogram (Def_Id)
- then
- -- If the name is overloaded, pragma applies to all of the denoted
- -- entities in the same declarative part, unless the pragma comes
- -- from an aspect specification.
+ -- If the entity is a derived boolean type, check for the special
+ -- case of convention C, C++, or Fortran, where we consider any
+ -- nonzero value to represent true.
- Hom_Id := Def_Id;
- while Present (Hom_Id) loop
+ if Is_Discrete_Type (E)
+ and then Root_Type (Etype (E)) = Standard_Boolean
+ and then
+ (C = Convention_C
+ or else
+ C = Convention_CPP
+ or else
+ C = Convention_Fortran)
+ then
+ Set_Nonzero_Is_True (Base_Type (E));
+ end if;
+ end Set_Convention_From_Pragma;
- Def_Id := Get_Base_Subprogram (Hom_Id);
+ -- Start of processing for Process_Convention
- -- Ignore inherited subprograms because the pragma will apply
- -- to the parent operation, which is the one called.
+ begin
+ Check_At_Least_N_Arguments (2);
+ Check_Optional_Identifier (Arg1, Name_Convention);
+ Check_Arg_Is_Identifier (Arg1);
+ Cname := Chars (Get_Pragma_Arg (Arg1));
- if Is_Overloadable (Def_Id)
- and then Present (Alias (Def_Id))
- then
- null;
+ -- C_Pass_By_Copy is treated as a synonym for convention C (this is
+ -- tested again below to set the critical flag).
- -- If it is not a subprogram, it must be in an outer scope and
- -- pragma does not apply.
+ if Cname = Name_C_Pass_By_Copy then
+ C := Convention_C;
- elsif not Is_Subprogram (Def_Id)
- and then not Is_Generic_Subprogram (Def_Id)
- then
- null;
+ -- Otherwise we must have something in the standard convention list
- -- The pragma does not apply to primitives of interfaces
+ elsif Is_Convention_Name (Cname) then
+ C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
- elsif Is_Dispatching_Operation (Def_Id)
- and then Present (Find_Dispatching_Type (Def_Id))
- and then Is_Interface (Find_Dispatching_Type (Def_Id))
- then
- null;
+ -- In DEC VMS, it seems that there is an undocumented feature that
+ -- any unrecognized convention is treated as the default, which for
+ -- us is convention C. It does not seem so terrible to do this
+ -- unconditionally, silently in the VMS case, and with a warning
+ -- in the non-VMS case.
- -- Verify that the homonym is in the same declarative part (not
- -- just the same scope). If the pragma comes from an aspect
- -- specification we know that it is part of the declaration.
+ else
+ if Warn_On_Export_Import and not OpenVMS_On_Target then
+ Error_Msg_N
+ ("??unrecognized convention name, C assumed",
+ Get_Pragma_Arg (Arg1));
+ end if;
- elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
- and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
- and then not From_Aspect_Specification (N)
- then
- exit;
+ C := Convention_C;
+ end if;
- else
- Set_Imported (Def_Id);
+ Check_Optional_Identifier (Arg2, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg2);
- -- Reject an Import applied to an abstract subprogram
+ Id := Get_Pragma_Arg (Arg2);
+ Analyze (Id);
- if Is_Subprogram (Def_Id)
- and then Is_Abstract_Subprogram (Def_Id)
- then
- Error_Msg_Sloc := Sloc (Def_Id);
- Error_Msg_NE
- ("cannot import abstract subprogram& declared#",
- Arg2, Def_Id);
- end if;
+ if not Is_Entity_Name (Id) then
+ Error_Pragma_Arg ("entity name required", Arg2);
+ end if;
- -- Special processing for Convention_Intrinsic
+ E := Entity (Id);
- if C = Convention_Intrinsic then
+ -- Set entity to return
- -- Link_Name argument not allowed for intrinsic
+ Ent := E;
- Check_No_Link_Name;
+ -- Ada_Pass_By_Copy special checking
- Set_Is_Intrinsic_Subprogram (Def_Id);
+ if C = Convention_Ada_Pass_By_Copy then
+ if not Is_First_Subtype (E) then
+ Error_Pragma_Arg
+ ("convention `Ada_Pass_By_Copy` only "
+ & "allowed for types", Arg2);
+ end if;
- -- If no external name is present, then check that this
- -- is a valid intrinsic subprogram. If an external name
- -- is present, then this is handled by the back end.
+ if Is_By_Reference_Type (E) then
+ Error_Pragma_Arg
+ ("convention `Ada_Pass_By_Copy` not allowed for "
+ & "by-reference type", Arg1);
+ end if;
+ end if;
- if No (Arg3) then
- Check_Intrinsic_Subprogram
- (Def_Id, Get_Pragma_Arg (Arg2));
- end if;
- end if;
+ -- Ada_Pass_By_Reference special checking
- -- All interfaced procedures need an external symbol created
- -- for them since they are always referenced from another
- -- object file.
+ if C = Convention_Ada_Pass_By_Reference then
+ if not Is_First_Subtype (E) then
+ Error_Pragma_Arg
+ ("convention `Ada_Pass_By_Reference` only "
+ & "allowed for types", Arg2);
+ end if;
- Set_Is_Public (Def_Id);
+ if Is_By_Copy_Type (E) then
+ Error_Pragma_Arg
+ ("convention `Ada_Pass_By_Reference` not allowed for "
+ & "by-copy type", Arg1);
+ end if;
+ end if;
- -- Verify that the subprogram does not have a completion
- -- through a renaming declaration. For other completions the
- -- pragma appears as a too late representation.
+ -- Go to renamed subprogram if present, since convention applies to
+ -- the actual renamed entity, not to the renaming entity. If the
+ -- subprogram is inherited, go to parent subprogram.
- declare
- Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
+ if Is_Subprogram (E)
+ and then Present (Alias (E))
+ then
+ if Nkind (Parent (Declaration_Node (E))) =
+ N_Subprogram_Renaming_Declaration
+ then
+ if Scope (E) /= Scope (Alias (E)) then
+ Error_Pragma_Ref
+ ("cannot apply pragma% to non-local entity&#", E);
+ end if;
- begin
- if Present (Decl)
- and then Nkind (Decl) = N_Subprogram_Declaration
- and then Present (Corresponding_Body (Decl))
- and then Nkind (Unit_Declaration_Node
- (Corresponding_Body (Decl))) =
- N_Subprogram_Renaming_Declaration
- then
- Error_Msg_Sloc := Sloc (Def_Id);
- Error_Msg_NE
- ("cannot import&, renaming already provided for "
- & "declaration #", N, Def_Id);
- end if;
- end;
+ E := Alias (E);
+
+ elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
+ N_Private_Extension_Declaration)
+ and then Scope (E) = Scope (Alias (E))
+ then
+ E := Alias (E);
+
+ -- Return the parent subprogram the entity was inherited from
+
+ Ent := E;
+ end if;
+ end if;
+
+ -- Check that we are not applying this to a specless body
+ -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada
+ -- compilers.
+
+ if Is_Subprogram (E)
+ and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
+ and then not Relaxed_RM_Semantics
+ then
+ Error_Pragma
+ ("pragma% requires separate spec and must come before body");
+ end if;
+
+ -- Check that we are not applying this to a named constant
- Set_Has_Completion (Def_Id);
- Process_Interface_Name (Def_Id, Arg3, Arg4);
- end if;
+ if Ekind_In (E, E_Named_Integer, E_Named_Real) then
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N
+ ("cannot apply pragma% to named constant!",
+ Get_Pragma_Arg (Arg2));
+ Error_Pragma_Arg
+ ("\supply appropriate type for&!", Arg2);
+ end if;
- if Is_Compilation_Unit (Hom_Id) then
+ if Ekind (E) = E_Enumeration_Literal then
+ Error_Pragma ("enumeration literal not allowed for pragma%");
+ end if;
- -- Its possible homonyms are not affected by the pragma.
- -- Such homonyms might be present in the context of other
- -- units being compiled.
+ -- Check for rep item appearing too early or too late
- exit;
+ if Etype (E) = Any_Type
+ or else Rep_Item_Too_Early (E, N)
+ then
+ raise Pragma_Exit;
- elsif From_Aspect_Specification (N) then
- exit;
+ elsif Present (Underlying_Type (E)) then
+ E := Underlying_Type (E);
+ end if;
- else
- Hom_Id := Homonym (Hom_Id);
- end if;
- end loop;
+ if Rep_Item_Too_Late (E, N) then
+ raise Pragma_Exit;
+ end if;
- -- When the convention is Java or CIL, we also allow Import to be
- -- given for packages, generic packages, exceptions, record
- -- components, and access to subprograms.
+ if Has_Convention_Pragma (E) then
+ Diagnose_Multiple_Pragmas (E);
- elsif (C = Convention_Java or else C = Convention_CIL)
- and then
- (Is_Package_Or_Generic_Package (Def_Id)
- or else Ekind (Def_Id) = E_Exception
- or else Ekind (Def_Id) = E_Access_Subprogram_Type
- or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
+ elsif Convention (E) = Convention_Protected
+ or else Ekind (Scope (E)) = E_Protected_Type
then
- Set_Imported (Def_Id);
- Set_Is_Public (Def_Id);
- Process_Interface_Name (Def_Id, Arg3, Arg4);
+ Error_Pragma_Arg
+ ("a protected operation cannot be given a different convention",
+ Arg2);
+ end if;
- -- Import a CPP class
+ -- For Intrinsic, a subprogram is required
- elsif C = Convention_CPP
- and then (Is_Record_Type (Def_Id)
- or else Ekind (Def_Id) = E_Incomplete_Type)
+ if C = Convention_Intrinsic
+ and then not Is_Subprogram (E)
+ and then not Is_Generic_Subprogram (E)
then
- if Ekind (Def_Id) = E_Incomplete_Type then
- if Present (Full_View (Def_Id)) then
- Def_Id := Full_View (Def_Id);
+ Error_Pragma_Arg
+ ("second argument of pragma% must be a subprogram", Arg2);
+ end if;
- else
- Error_Msg_N
- ("cannot import 'C'P'P type before full declaration seen",
- Get_Pragma_Arg (Arg2));
+ -- Stdcall case
- -- Although we have reported the error we decorate it as
- -- CPP_Class to avoid reporting spurious errors
+ if C = Convention_Stdcall then
- Set_Is_CPP_Class (Def_Id);
- return;
- end if;
- end if;
+ -- A dispatching call is not allowed. A dispatching subprogram
+ -- cannot be used to interface to the Win32 API, so in fact this
+ -- check does not impose any effective restriction.
- -- Types treated as CPP classes must be declared limited (note:
- -- this used to be a warning but there is no real benefit to it
- -- since we did effectively intend to treat the type as limited
- -- anyway).
+ if Is_Dispatching_Operation (E) then
- if not Is_Limited_Type (Def_Id) then
- Error_Msg_N
- ("imported 'C'P'P type must be limited",
- Get_Pragma_Arg (Arg2));
- end if;
+ Error_Pragma
+ ("dispatching subprograms cannot use Stdcall convention");
- if Etype (Def_Id) /= Def_Id
- and then not Is_CPP_Class (Root_Type (Def_Id))
- then
- Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
- end if;
+ -- Subprogram is allowed, but not a generic subprogram, and not a
+ -- dispatching operation.
- Set_Is_CPP_Class (Def_Id);
+ elsif not Is_Subprogram (E)
+ and then not Is_Generic_Subprogram (E)
- -- Imported CPP types must not have discriminants (because C++
- -- classes do not have discriminants).
+ -- A variable is OK
- if Has_Discriminants (Def_Id) then
- Error_Msg_N
- ("imported 'C'P'P type cannot have discriminants",
- First (Discriminant_Specifications
- (Declaration_Node (Def_Id))));
- end if;
+ and then Ekind (E) /= E_Variable
- -- Check that components of imported CPP types do not have default
- -- expressions. For private types this check is performed when the
- -- full view is analyzed (see Process_Full_View).
+ -- An access to subprogram is also allowed
- if not Is_Private_Type (Def_Id) then
- Check_CPP_Type_Has_No_Defaults (Def_Id);
+ and then not
+ (Is_Access_Type (E)
+ and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
+ then
+ Error_Pragma_Arg
+ ("second argument of pragma% must be subprogram (type)",
+ Arg2);
end if;
+ end if;
- elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
- Check_No_Link_Name;
- Check_Arg_Count (3);
- Check_Arg_Is_Static_Expression (Arg3, Standard_String);
+ if not Is_Subprogram (E)
+ and then not Is_Generic_Subprogram (E)
+ then
+ Set_Convention_From_Pragma (E);
- Process_Import_Predefined_Type;
+ if Is_Type (E) then
+ Check_First_Subtype (Arg2);
+ Set_Convention_From_Pragma (Base_Type (E));
- else
- Error_Pragma_Arg
- ("second argument of pragma% must be object, subprogram "
- & "or incomplete type",
- Arg2);
- end if;
+ -- For subprograms, we must set the convention on the
+ -- internally generated directly designated type as well.
- -- If this pragma applies to a compilation unit, then the unit, which
- -- is a subprogram, does not require (or allow) a body. We also do
- -- not need to elaborate imported procedures.
+ if Ekind (E) = E_Access_Subprogram_Type then
+ Set_Convention_From_Pragma (Directly_Designated_Type (E));
+ end if;
+ end if;
- if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
- declare
- Cunit : constant Node_Id := Parent (Parent (N));
- begin
- Set_Body_Required (Cunit, False);
- end;
- end if;
- end Process_Import_Or_Interface;
+ -- For the subprogram case, set proper convention for all homonyms
+ -- in same scope and the same declarative part, i.e. the same
+ -- compilation unit.
- --------------------
- -- Process_Inline --
- --------------------
+ else
+ Comp_Unit := Get_Source_Unit (E);
+ Set_Convention_From_Pragma (E);
- procedure Process_Inline (Status : Inline_Status) is
- Assoc : Node_Id;
- Decl : Node_Id;
- Subp_Id : Node_Id;
- Subp : Entity_Id;
- Applies : Boolean;
+ -- Treat a pragma Import as an implicit body, and pragma import
+ -- as implicit reference (for navigation in GPS).
- Effective : Boolean := False;
- -- Set True if inline has some effect, i.e. if there is at least one
- -- subprogram set as inlined as a result of the use of the pragma.
+ if Prag_Id = Pragma_Import then
+ Generate_Reference (E, Id, 'b');
- procedure Make_Inline (Subp : Entity_Id);
- -- Subp is the defining unit name of the subprogram declaration. Set
- -- the flag, as well as the flag in the corresponding body, if there
- -- is one present.
+ -- For exported entities we restrict the generation of references
+ -- to entities exported to foreign languages since entities
+ -- exported to Ada do not provide further information to GPS and
+ -- add undesired references to the output of the gnatxref tool.
- procedure Set_Inline_Flags (Subp : Entity_Id);
- -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
- -- Has_Pragma_Inline_Always for the Inline_Always case.
+ elsif Prag_Id = Pragma_Export
+ and then Convention (E) /= Convention_Ada
+ then
+ Generate_Reference (E, Id, 'i');
+ end if;
- function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
- -- Returns True if it can be determined at this stage that inlining
- -- is not possible, for example if the body is available and contains
- -- exception handlers, we prevent inlining, since otherwise we can
- -- get undefined symbols at link time. This function also emits a
- -- warning if front-end inlining is enabled and the pragma appears
- -- too late.
- --
- -- ??? is business with link symbols still valid, or does it relate
- -- to front end ZCX which is being phased out ???
+ -- If the pragma comes from from an aspect, it only applies
+ -- to the given entity, not its homonyms.
- ---------------------------
- -- Inlining_Not_Possible --
- ---------------------------
+ if From_Aspect_Specification (N) then
+ return;
+ end if;
- function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
- Decl : constant Node_Id := Unit_Declaration_Node (Subp);
- Stats : Node_Id;
+ -- Otherwise Loop through the homonyms of the pragma argument's
+ -- entity, an apply convention to those in the current scope.
- begin
- if Nkind (Decl) = N_Subprogram_Body then
- Stats := Handled_Statement_Sequence (Decl);
- return Present (Exception_Handlers (Stats))
- or else Present (At_End_Proc (Stats));
+ E1 := Ent;
- elsif Nkind (Decl) = N_Subprogram_Declaration
- and then Present (Corresponding_Body (Decl))
- then
- if Front_End_Inlining
- and then Analyzed (Corresponding_Body (Decl))
- then
- Error_Msg_N ("pragma appears too late, ignored??", N);
- return True;
+ loop
+ E1 := Homonym (E1);
+ exit when No (E1) or else Scope (E1) /= Current_Scope;
- -- If the subprogram is a renaming as body, the body is just a
- -- call to the renamed subprogram, and inlining is trivially
- -- possible.
+ -- Do not set the pragma on inherited operations or on formal
+ -- subprograms.
- elsif
- Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
- N_Subprogram_Renaming_Declaration
+ if Comes_From_Source (E1)
+ and then Comp_Unit = Get_Source_Unit (E1)
+ and then not Is_Formal_Subprogram (E1)
+ and then Nkind (Original_Node (Parent (E1))) /=
+ N_Full_Type_Declaration
then
- return False;
+ if Present (Alias (E1))
+ and then Scope (E1) /= Scope (Alias (E1))
+ then
+ Error_Pragma_Ref
+ ("cannot apply pragma% to non-local entity& declared#",
+ E1);
+ end if;
- else
- Stats :=
- Handled_Statement_Sequence
- (Unit_Declaration_Node (Corresponding_Body (Decl)));
+ Set_Convention_From_Pragma (E1);
- return
- Present (Exception_Handlers (Stats))
- or else Present (At_End_Proc (Stats));
+ if Prag_Id = Pragma_Import then
+ Generate_Reference (E1, Id, 'b');
+ end if;
end if;
+ end loop;
+ end if;
+ end Process_Convention;
- else
- -- If body is not available, assume the best, the check is
- -- performed again when compiling enclosing package bodies.
-
- return False;
- end if;
- end Inlining_Not_Possible;
+ ----------------------------------------
+ -- Process_Disable_Enable_Atomic_Sync --
+ ----------------------------------------
- -----------------
- -- Make_Inline --
- -----------------
+ procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
+ begin
+ GNAT_Pragma;
+ Check_No_Identifiers;
+ Check_At_Most_N_Arguments (1);
- procedure Make_Inline (Subp : Entity_Id) is
- Kind : constant Entity_Kind := Ekind (Subp);
- Inner_Subp : Entity_Id := Subp;
+ -- Modeled internally as
+ -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
- begin
- -- Ignore if bad type, avoid cascaded error
+ Rewrite (N,
+ Make_Pragma (Loc,
+ Pragma_Identifier =>
+ Make_Identifier (Loc, Nam),
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression =>
+ Make_Identifier (Loc, Name_Atomic_Synchronization)))));
- if Etype (Subp) = Any_Type then
- Applies := True;
- return;
+ if Present (Arg1) then
+ Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
+ end if;
- -- Ignore if all inlining is suppressed
+ Analyze (N);
+ end Process_Disable_Enable_Atomic_Sync;
- elsif Suppress_All_Inlining then
- Applies := True;
- return;
+ -----------------------------------------------------
+ -- Process_Extended_Import_Export_Exception_Pragma --
+ -----------------------------------------------------
- -- If inlining is not possible, for now do not treat as an error
+ procedure Process_Extended_Import_Export_Exception_Pragma
+ (Arg_Internal : Node_Id;
+ Arg_External : Node_Id;
+ Arg_Form : Node_Id;
+ Arg_Code : Node_Id)
+ is
+ Def_Id : Entity_Id;
+ Code_Val : Uint;
- elsif Status /= Suppressed
- and then Inlining_Not_Possible (Subp)
- then
- Applies := True;
- return;
+ begin
+ if not OpenVMS_On_Target then
+ Error_Pragma
+ ("??pragma% ignored (applies only to Open'V'M'S)");
+ end if;
- -- Here we have a candidate for inlining, but we must exclude
- -- derived operations. Otherwise we would end up trying to inline
- -- a phantom declaration, and the result would be to drag in a
- -- body which has no direct inlining associated with it. That
- -- would not only be inefficient but would also result in the
- -- backend doing cross-unit inlining in cases where it was
- -- definitely inappropriate to do so.
+ Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
+ Def_Id := Entity (Arg_Internal);
- -- However, a simple Comes_From_Source test is insufficient, since
- -- we do want to allow inlining of generic instances which also do
- -- not come from source. We also need to recognize specs generated
- -- by the front-end for bodies that carry the pragma. Finally,
- -- predefined operators do not come from source but are not
- -- inlineable either.
+ if Ekind (Def_Id) /= E_Exception then
+ Error_Pragma_Arg
+ ("pragma% must refer to declared exception", Arg_Internal);
+ end if;
- elsif Is_Generic_Instance (Subp)
- or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
- then
- null;
+ Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
- elsif not Comes_From_Source (Subp)
- and then Scope (Subp) /= Standard_Standard
- then
- Applies := True;
- return;
- end if;
+ if Present (Arg_Form) then
+ Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
+ end if;
- -- The referenced entity must either be the enclosing entity, or
- -- an entity declared within the current open scope.
+ if Present (Arg_Form)
+ and then Chars (Arg_Form) = Name_Ada
+ then
+ null;
+ else
+ Set_Is_VMS_Exception (Def_Id);
+ Set_Exception_Code (Def_Id, No_Uint);
+ end if;
- if Present (Scope (Subp))
- and then Scope (Subp) /= Current_Scope
- and then Subp /= Current_Scope
- then
+ if Present (Arg_Code) then
+ if not Is_VMS_Exception (Def_Id) then
Error_Pragma_Arg
- ("argument of% must be entity in current scope", Assoc);
- return;
+ ("Code option for pragma% not allowed for Ada case",
+ Arg_Code);
end if;
- -- Processing for procedure, operator or function. If subprogram
- -- is aliased (as for an instance) indicate that the renamed
- -- entity (if declared in the same unit) is inlined.
+ Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
+ Code_Val := Expr_Value (Arg_Code);
- if Is_Subprogram (Subp) then
- Inner_Subp := Ultimate_Alias (Inner_Subp);
+ if not UI_Is_In_Int_Range (Code_Val) then
+ Error_Pragma_Arg
+ ("Code option for pragma% must be in 32-bit range",
+ Arg_Code);
- if In_Same_Source_Unit (Subp, Inner_Subp) then
- Set_Inline_Flags (Inner_Subp);
+ else
+ Set_Exception_Code (Def_Id, Code_Val);
+ end if;
+ end if;
+ end Process_Extended_Import_Export_Exception_Pragma;
- Decl := Parent (Parent (Inner_Subp));
+ -------------------------------------------------
+ -- Process_Extended_Import_Export_Internal_Arg --
+ -------------------------------------------------
- if Nkind (Decl) = N_Subprogram_Declaration
- and then Present (Corresponding_Body (Decl))
- then
- Set_Inline_Flags (Corresponding_Body (Decl));
+ procedure Process_Extended_Import_Export_Internal_Arg
+ (Arg_Internal : Node_Id := Empty)
+ is
+ begin
+ if No (Arg_Internal) then
+ Error_Pragma ("Internal parameter required for pragma%");
+ end if;
- elsif Is_Generic_Instance (Subp) then
+ if Nkind (Arg_Internal) = N_Identifier then
+ null;
- -- Indicate that the body needs to be created for
- -- inlining subsequent calls. The instantiation node
- -- follows the declaration of the wrapper package
- -- created for it.
+ elsif Nkind (Arg_Internal) = N_Operator_Symbol
+ and then (Prag_Id = Pragma_Import_Function
+ or else
+ Prag_Id = Pragma_Export_Function)
+ then
+ null;
- if Scope (Subp) /= Standard_Standard
- and then
- Need_Subprogram_Instance_Body
- (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
- Subp)
- then
- null;
- end if;
+ else
+ Error_Pragma_Arg
+ ("wrong form for Internal parameter for pragma%", Arg_Internal);
+ end if;
- -- Inline is a program unit pragma (RM 10.1.5) and cannot
- -- appear in a formal part to apply to a formal subprogram.
- -- Do not apply check within an instance or a formal package
- -- the test will have been applied to the original generic.
+ Check_Arg_Is_Local_Name (Arg_Internal);
+ end Process_Extended_Import_Export_Internal_Arg;
- elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
- and then List_Containing (Decl) = List_Containing (N)
- and then not In_Instance
- then
- Error_Msg_N
- ("Inline cannot apply to a formal subprogram", N);
+ --------------------------------------------------
+ -- Process_Extended_Import_Export_Object_Pragma --
+ --------------------------------------------------
- -- If Subp is a renaming, it is the renamed entity that
- -- will appear in any call, and be inlined. However, for
- -- ASIS uses it is convenient to indicate that the renaming
- -- itself is an inlined subprogram, so that some gnatcheck
- -- rules can be applied in the absence of expansion.
+ procedure Process_Extended_Import_Export_Object_Pragma
+ (Arg_Internal : Node_Id;
+ Arg_External : Node_Id;
+ Arg_Size : Node_Id)
+ is
+ Def_Id : Entity_Id;
- elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
- Set_Inline_Flags (Subp);
- end if;
- end if;
+ begin
+ Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
+ Def_Id := Entity (Arg_Internal);
- Applies := True;
+ if not Ekind_In (Def_Id, E_Constant, E_Variable) then
+ Error_Pragma_Arg
+ ("pragma% must designate an object", Arg_Internal);
+ end if;
- -- For a generic subprogram set flag as well, for use at the point
- -- of instantiation, to determine whether the body should be
- -- generated.
+ if Has_Rep_Pragma (Def_Id, Name_Common_Object)
+ or else
+ Has_Rep_Pragma (Def_Id, Name_Psect_Object)
+ then
+ Error_Pragma_Arg
+ ("previous Common/Psect_Object applies, pragma % not permitted",
+ Arg_Internal);
+ end if;
- elsif Is_Generic_Subprogram (Subp) then
- Set_Inline_Flags (Subp);
- Applies := True;
+ if Rep_Item_Too_Late (Def_Id, N) then
+ raise Pragma_Exit;
+ end if;
- -- Literals are by definition inlined
+ Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
- elsif Kind = E_Enumeration_Literal then
- null;
+ if Present (Arg_Size) then
+ Check_Arg_Is_External_Name (Arg_Size);
+ end if;
- -- Anything else is an error
+ -- Export_Object case
- else
+ if Prag_Id = Pragma_Export_Object then
+ if not Is_Library_Level_Entity (Def_Id) then
Error_Pragma_Arg
- ("expect subprogram name for pragma%", Assoc);
+ ("argument for pragma% must be library level entity",
+ Arg_Internal);
end if;
- end Make_Inline;
- ----------------------
- -- Set_Inline_Flags --
- ----------------------
-
- procedure Set_Inline_Flags (Subp : Entity_Id) is
- begin
- -- First set the Has_Pragma_XXX flags and issue the appropriate
- -- errors and warnings for suspicious combinations.
+ if Ekind (Current_Scope) = E_Generic_Package then
+ Error_Pragma ("pragma& cannot appear in a generic unit");
+ end if;
- if Prag_Id = Pragma_No_Inline then
- if Has_Pragma_Inline_Always (Subp) then
- Error_Msg_N
- ("Inline_Always and No_Inline are mutually exclusive", N);
- elsif Has_Pragma_Inline (Subp) then
- Error_Msg_NE
- ("Inline and No_Inline both specified for& ??",
- N, Entity (Subp_Id));
- end if;
+ if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
+ Error_Pragma_Arg
+ ("exported object must have compile time known size",
+ Arg_Internal);
+ end if;
- Set_Has_Pragma_No_Inline (Subp);
+ if Warn_On_Export_Import and then Is_Exported (Def_Id) then
+ Error_Msg_N ("??duplicate Export_Object pragma", N);
else
- if Prag_Id = Pragma_Inline_Always then
- if Has_Pragma_No_Inline (Subp) then
- Error_Msg_N
- ("Inline_Always and No_Inline are mutually exclusive",
- N);
- end if;
-
- Set_Has_Pragma_Inline_Always (Subp);
- else
- if Has_Pragma_No_Inline (Subp) then
- Error_Msg_NE
- ("Inline and No_Inline both specified for& ??",
- N, Entity (Subp_Id));
- end if;
- end if;
-
- if not Has_Pragma_Inline (Subp) then
- Set_Has_Pragma_Inline (Subp);
- Effective := True;
- end if;
+ Set_Exported (Def_Id, Arg_Internal);
end if;
- -- Then adjust the Is_Inlined flag. It can never be set if the
- -- subprogram is subject to pragma No_Inline.
+ -- Import_Object case
- case Status is
- when Suppressed =>
- Set_Is_Inlined (Subp, False);
- when Disabled =>
- null;
- when Enabled =>
- if not Has_Pragma_No_Inline (Subp) then
- Set_Is_Inlined (Subp, True);
- end if;
- end case;
- end Set_Inline_Flags;
+ else
+ if Is_Concurrent_Type (Etype (Def_Id)) then
+ Error_Pragma_Arg
+ ("cannot use pragma% for task/protected object",
+ Arg_Internal);
+ end if;
- -- Start of processing for Process_Inline
+ if Ekind (Def_Id) = E_Constant then
+ Error_Pragma_Arg
+ ("cannot import a constant", Arg_Internal);
+ end if;
- begin
- Check_No_Identifiers;
- Check_At_Least_N_Arguments (1);
+ if Warn_On_Export_Import
+ and then Has_Discriminants (Etype (Def_Id))
+ then
+ Error_Msg_N
+ ("imported value must be initialized??", Arg_Internal);
+ end if;
- if Status = Enabled then
- Inline_Processing_Required := True;
- end if;
+ if Warn_On_Export_Import
+ and then Is_Access_Type (Etype (Def_Id))
+ then
+ Error_Pragma_Arg
+ ("cannot import object of an access type??", Arg_Internal);
+ end if;
- Assoc := Arg1;
- while Present (Assoc) loop
- Subp_Id := Get_Pragma_Arg (Assoc);
- Analyze (Subp_Id);
- Applies := False;
+ if Warn_On_Export_Import
+ and then Is_Imported (Def_Id)
+ then
+ Error_Msg_N ("??duplicate Import_Object pragma", N);
- if Is_Entity_Name (Subp_Id) then
- Subp := Entity (Subp_Id);
+ -- Check for explicit initialization present. Note that an
+ -- initialization generated by the code generator, e.g. for an
+ -- access type, does not count here.
- if Subp = Any_Id then
+ elsif Present (Expression (Parent (Def_Id)))
+ and then
+ Comes_From_Source
+ (Original_Node (Expression (Parent (Def_Id))))
+ then
+ Error_Msg_Sloc := Sloc (Def_Id);
+ Error_Pragma_Arg
+ ("imported entities cannot be initialized (RM B.1(24))",
+ "\no initialization allowed for & declared#", Arg1);
+ else
+ Set_Imported (Def_Id);
+ Note_Possible_Modification (Arg_Internal, Sure => False);
+ end if;
+ end if;
+ end Process_Extended_Import_Export_Object_Pragma;
- -- If previous error, avoid cascaded errors
+ ------------------------------------------------------
+ -- Process_Extended_Import_Export_Subprogram_Pragma --
+ ------------------------------------------------------
- Check_Error_Detected;
- Applies := True;
- Effective := True;
+ procedure Process_Extended_Import_Export_Subprogram_Pragma
+ (Arg_Internal : Node_Id;
+ Arg_External : Node_Id;
+ Arg_Parameter_Types : Node_Id;
+ Arg_Result_Type : Node_Id := Empty;
+ Arg_Mechanism : Node_Id;
+ Arg_Result_Mechanism : Node_Id := Empty;
+ Arg_First_Optional_Parameter : Node_Id := Empty)
+ is
+ Ent : Entity_Id;
+ Def_Id : Entity_Id;
+ Hom_Id : Entity_Id;
+ Formal : Entity_Id;
+ Ambiguous : Boolean;
+ Match : Boolean;
+ Dval : Node_Id;
- else
- Make_Inline (Subp);
+ function Same_Base_Type
+ (Ptype : Node_Id;
+ Formal : Entity_Id) return Boolean;
+ -- Determines if Ptype references the type of Formal. Note that only
+ -- the base types need to match according to the spec. Ptype here is
+ -- the argument from the pragma, which is either a type name, or an
+ -- access attribute.
- -- For the pragma case, climb homonym chain. This is
- -- what implements allowing the pragma in the renaming
- -- case, with the result applying to the ancestors, and
- -- also allows Inline to apply to all previous homonyms.
+ --------------------
+ -- Same_Base_Type --
+ --------------------
- if not From_Aspect_Specification (N) then
- while Present (Homonym (Subp))
- and then Scope (Homonym (Subp)) = Current_Scope
- loop
- Make_Inline (Homonym (Subp));
- Subp := Homonym (Subp);
- end loop;
- end if;
- end if;
- end if;
+ function Same_Base_Type
+ (Ptype : Node_Id;
+ Formal : Entity_Id) return Boolean
+ is
+ Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
+ Pref : Node_Id;
- if not Applies then
- Error_Pragma_Arg
- ("inappropriate argument for pragma%", Assoc);
+ begin
+ -- Case where pragma argument is typ'Access
- elsif not Effective
- and then Warn_On_Redundant_Constructs
- and then not (Status = Suppressed or else Suppress_All_Inlining)
+ if Nkind (Ptype) = N_Attribute_Reference
+ and then Attribute_Name (Ptype) = Name_Access
then
- if Inlining_Not_Possible (Subp) then
- Error_Msg_NE
- ("pragma Inline for& is ignored?r?",
- N, Entity (Subp_Id));
- else
- Error_Msg_NE
- ("pragma Inline for& is redundant?r?",
- N, Entity (Subp_Id));
+ Pref := Prefix (Ptype);
+ Find_Type (Pref);
+
+ if not Is_Entity_Name (Pref)
+ or else Entity (Pref) = Any_Type
+ then
+ raise Pragma_Exit;
end if;
- end if;
- Next (Assoc);
- end loop;
- end Process_Inline;
+ -- We have a match if the corresponding argument is of an
+ -- anonymous access type, and its designated type matches the
+ -- type of the prefix of the access attribute
- ----------------------------
- -- Process_Interface_Name --
- ----------------------------
+ return Ekind (Ftyp) = E_Anonymous_Access_Type
+ and then Base_Type (Entity (Pref)) =
+ Base_Type (Etype (Designated_Type (Ftyp)));
- procedure Process_Interface_Name
- (Subprogram_Def : Entity_Id;
- Ext_Arg : Node_Id;
- Link_Arg : Node_Id)
- is
- Ext_Nam : Node_Id;
- Link_Nam : Node_Id;
- String_Val : String_Id;
+ -- Case where pragma argument is a type name
- procedure Check_Form_Of_Interface_Name
- (SN : Node_Id;
- Ext_Name_Case : Boolean);
- -- SN is a string literal node for an interface name. This routine
- -- performs some minimal checks that the name is reasonable. In
- -- particular that no spaces or other obviously incorrect characters
- -- appear. This is only a warning, since any characters are allowed.
- -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
+ else
+ Find_Type (Ptype);
- ----------------------------------
- -- Check_Form_Of_Interface_Name --
- ----------------------------------
+ if not Is_Entity_Name (Ptype)
+ or else Entity (Ptype) = Any_Type
+ then
+ raise Pragma_Exit;
+ end if;
- procedure Check_Form_Of_Interface_Name
- (SN : Node_Id;
- Ext_Name_Case : Boolean)
- is
- S : constant String_Id := Strval (Expr_Value_S (SN));
- SL : constant Nat := String_Length (S);
- C : Char_Code;
+ -- We have a match if the corresponding argument is of the type
+ -- given in the pragma (comparing base types)
- begin
- if SL = 0 then
- Error_Msg_N ("interface name cannot be null string", SN);
+ return Base_Type (Entity (Ptype)) = Ftyp;
end if;
+ end Same_Base_Type;
- for J in 1 .. SL loop
- C := Get_String_Char (S, J);
+ -- Start of processing for
+ -- Process_Extended_Import_Export_Subprogram_Pragma
- -- Look for dubious character and issue unconditional warning.
- -- Definitely dubious if not in character range.
+ begin
+ Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
+ Ent := Empty;
+ Ambiguous := False;
- if not In_Character_Range (C)
+ -- Loop through homonyms (overloadings) of the entity
- -- For all cases except CLI target,
- -- commas, spaces and slashes are dubious (in CLI, we use
- -- commas and backslashes in external names to specify
- -- assembly version and public key, while slashes and spaces
- -- can be used in names to mark nested classes and
- -- valuetypes).
+ Hom_Id := Entity (Arg_Internal);
+ while Present (Hom_Id) loop
+ Def_Id := Get_Base_Subprogram (Hom_Id);
- or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
- and then (Get_Character (C) = ','
- or else
- Get_Character (C) = '\'))
- or else (VM_Target /= CLI_Target
- and then (Get_Character (C) = ' '
- or else
- Get_Character (C) = '/'))
+ -- We need a subprogram in the current scope
+
+ if not Is_Subprogram (Def_Id)
+ or else Scope (Def_Id) /= Current_Scope
+ then
+ null;
+
+ else
+ Match := True;
+
+ -- Pragma cannot apply to subprogram body
+
+ if Is_Subprogram (Def_Id)
+ and then Nkind (Parent (Declaration_Node (Def_Id))) =
+ N_Subprogram_Body
then
- Error_Msg
- ("??interface name contains illegal character",
- Sloc (SN) + Source_Ptr (J));
+ Error_Pragma
+ ("pragma% requires separate spec"
+ & " and must come before body");
end if;
- end loop;
- end Check_Form_Of_Interface_Name;
- -- Start of processing for Process_Interface_Name
+ -- Test result type if given, note that the result type
+ -- parameter can only be present for the function cases.
- begin
- if No (Link_Arg) then
- if No (Ext_Arg) then
- if VM_Target = CLI_Target
- and then Ekind (Subprogram_Def) = E_Package
- and then Nkind (Parent (Subprogram_Def)) =
- N_Package_Specification
- and then Present (Generic_Parent (Parent (Subprogram_Def)))
+ if Present (Arg_Result_Type)
+ and then not Same_Base_Type (Arg_Result_Type, Def_Id)
then
- Set_Interface_Name
- (Subprogram_Def,
- Interface_Name
- (Generic_Parent (Parent (Subprogram_Def))));
- end if;
+ Match := False;
- return;
+ elsif Etype (Def_Id) /= Standard_Void_Type
+ and then
+ Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
+ then
+ Match := False;
- elsif Chars (Ext_Arg) = Name_Link_Name then
- Ext_Nam := Empty;
- Link_Nam := Expression (Ext_Arg);
+ -- Test parameter types if given. Note that this parameter
+ -- has not been analyzed (and must not be, since it is
+ -- semantic nonsense), so we get it as the parser left it.
- else
- Check_Optional_Identifier (Ext_Arg, Name_External_Name);
- Ext_Nam := Expression (Ext_Arg);
- Link_Nam := Empty;
- end if;
+ elsif Present (Arg_Parameter_Types) then
+ Check_Matching_Types : declare
+ Formal : Entity_Id;
+ Ptype : Node_Id;
- else
- Check_Optional_Identifier (Ext_Arg, Name_External_Name);
- Check_Optional_Identifier (Link_Arg, Name_Link_Name);
- Ext_Nam := Expression (Ext_Arg);
- Link_Nam := Expression (Link_Arg);
- end if;
+ begin
+ Formal := First_Formal (Def_Id);
- -- Check expressions for external name and link name are static
+ if Nkind (Arg_Parameter_Types) = N_Null then
+ if Present (Formal) then
+ Match := False;
+ end if;
- if Present (Ext_Nam) then
- Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
- Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
+ -- A list of one type, e.g. (List) is parsed as
+ -- a parenthesized expression.
- -- Verify that external name is not the name of a local entity,
- -- which would hide the imported one and could lead to run-time
- -- surprises. The problem can only arise for entities declared in
- -- a package body (otherwise the external name is fully qualified
- -- and will not conflict).
+ elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
+ and then Paren_Count (Arg_Parameter_Types) = 1
+ then
+ if No (Formal)
+ or else Present (Next_Formal (Formal))
+ then
+ Match := False;
+ else
+ Match :=
+ Same_Base_Type (Arg_Parameter_Types, Formal);
+ end if;
- declare
- Nam : Name_Id;
- E : Entity_Id;
- Par : Node_Id;
+ -- A list of more than one type is parsed as a aggregate
- begin
- if Prag_Id = Pragma_Import then
- String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
- Nam := Name_Find;
- E := Entity_Id (Get_Name_Table_Info (Nam));
+ elsif Nkind (Arg_Parameter_Types) = N_Aggregate
+ and then Paren_Count (Arg_Parameter_Types) = 0
+ then
+ Ptype := First (Expressions (Arg_Parameter_Types));
+ while Present (Ptype) or else Present (Formal) loop
+ if No (Ptype)
+ or else No (Formal)
+ or else not Same_Base_Type (Ptype, Formal)
+ then
+ Match := False;
+ exit;
+ else
+ Next_Formal (Formal);
+ Next (Ptype);
+ end if;
+ end loop;
- if Nam /= Chars (Subprogram_Def)
- and then Present (E)
- and then not Is_Overloadable (E)
- and then Is_Immediately_Visible (E)
- and then not Is_Imported (E)
- and then Ekind (Scope (E)) = E_Package
- then
- Par := Parent (E);
- while Present (Par) loop
- if Nkind (Par) = N_Package_Body then
- Error_Msg_Sloc := Sloc (E);
- Error_Msg_NE
- ("imported entity is hidden by & declared#",
- Ext_Arg, E);
- exit;
- end if;
+ -- Anything else is of the wrong form
- Par := Parent (Par);
- end loop;
+ else
+ Error_Pragma_Arg
+ ("wrong form for Parameter_Types parameter",
+ Arg_Parameter_Types);
+ end if;
+ end Check_Matching_Types;
+ end if;
+
+ -- Match is now False if the entry we found did not match
+ -- either a supplied Parameter_Types or Result_Types argument
+
+ if Match then
+ if No (Ent) then
+ Ent := Def_Id;
+
+ -- Ambiguous case, the flag Ambiguous shows if we already
+ -- detected this and output the initial messages.
+
+ else
+ if not Ambiguous then
+ Ambiguous := True;
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N
+ ("pragma% does not uniquely identify subprogram!",
+ N);
+ Error_Msg_Sloc := Sloc (Ent);
+ Error_Msg_N ("matching subprogram #!", N);
+ Ent := Empty;
+ end if;
+
+ Error_Msg_Sloc := Sloc (Def_Id);
+ Error_Msg_N ("matching subprogram #!", N);
end if;
end if;
- end;
- end if;
+ end if;
- if Present (Link_Nam) then
- Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
- Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
- end if;
+ Hom_Id := Homonym (Hom_Id);
+ end loop;
- -- If there is no link name, just set the external name
+ -- See if we found an entry
- if No (Link_Nam) then
- Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
+ if No (Ent) then
+ if not Ambiguous then
+ if Is_Generic_Subprogram (Entity (Arg_Internal)) then
+ Error_Pragma
+ ("pragma% cannot be given for generic subprogram");
+ else
+ Error_Pragma
+ ("pragma% does not identify local subprogram");
+ end if;
+ end if;
- -- For the Link_Name case, the given literal is preceded by an
- -- asterisk, which indicates to GCC that the given name should be
- -- taken literally, and in particular that no prepending of
- -- underlines should occur, even in systems where this is the
- -- normal default.
+ return;
+ end if;
+
+ -- Import pragmas must be for imported entities
+
+ if Prag_Id = Pragma_Import_Function
+ or else
+ Prag_Id = Pragma_Import_Procedure
+ or else
+ Prag_Id = Pragma_Import_Valued_Procedure
+ then
+ if not Is_Imported (Ent) then
+ Error_Pragma
+ ("pragma Import or Interface must precede pragma%");
+ end if;
- else
- Start_String;
+ -- Here we have the Export case which can set the entity as exported
- if VM_Target = No_VM then
- Store_String_Char (Get_Char_Code ('*'));
- end if;
+ -- But does not do so if the specified external name is null, since
+ -- that is taken as a signal in DEC Ada 83 (with which we want to be
+ -- compatible) to request no external name.
- String_Val := Strval (Expr_Value_S (Link_Nam));
- Store_String_Chars (String_Val);
- Link_Nam :=
- Make_String_Literal (Sloc (Link_Nam),
- Strval => End_String);
- end if;
+ elsif Nkind (Arg_External) = N_String_Literal
+ and then String_Length (Strval (Arg_External)) = 0
+ then
+ null;
- -- Set the interface name. If the entity is a generic instance, use
- -- its alias, which is the callable entity.
+ -- In all other cases, set entity as exported
- if Is_Generic_Instance (Subprogram_Def) then
- Set_Encoded_Interface_Name
- (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
else
- Set_Encoded_Interface_Name
- (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
+ Set_Exported (Ent, Arg_Internal);
end if;
- -- We allow duplicated export names in CIL/Java, as they are always
- -- enclosed in a namespace that differentiates them, and overloaded
- -- entities are supported by the VM.
+ -- Special processing for Valued_Procedure cases
- if Convention (Subprogram_Def) /= Convention_CIL
- and then
- Convention (Subprogram_Def) /= Convention_Java
+ if Prag_Id = Pragma_Import_Valued_Procedure
+ or else
+ Prag_Id = Pragma_Export_Valued_Procedure
then
- Check_Duplicated_Export_Name (Link_Nam);
- end if;
- end Process_Interface_Name;
+ Formal := First_Formal (Ent);
- -----------------------------------------
- -- Process_Interrupt_Or_Attach_Handler --
- -----------------------------------------
+ if No (Formal) then
+ Error_Pragma ("at least one parameter required for pragma%");
- procedure Process_Interrupt_Or_Attach_Handler is
- Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
- Handler_Proc : constant Entity_Id := Entity (Arg1_X);
- Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
+ elsif Ekind (Formal) /= E_Out_Parameter then
+ Error_Pragma ("first parameter must have mode out for pragma%");
- begin
- Set_Is_Interrupt_Handler (Handler_Proc);
+ else
+ Set_Is_Valued_Procedure (Ent);
+ end if;
+ end if;
- -- If the pragma is not associated with a handler procedure within a
- -- protected type, then it must be for a nonprotected procedure for
- -- the AAMP target, in which case we don't associate a representation
- -- item with the procedure's scope.
+ Set_Extended_Import_Export_External_Name (Ent, Arg_External);
- if Ekind (Proc_Scope) = E_Protected_Type then
- if Prag_Id = Pragma_Interrupt_Handler
- or else
- Prag_Id = Pragma_Attach_Handler
- then
- Record_Rep_Item (Proc_Scope, N);
- end if;
+ -- Process Result_Mechanism argument if present. We have already
+ -- checked that this is only allowed for the function case.
+
+ if Present (Arg_Result_Mechanism) then
+ Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
end if;
- end Process_Interrupt_Or_Attach_Handler;
- --------------------------------------------------
- -- Process_Restrictions_Or_Restriction_Warnings --
- --------------------------------------------------
+ -- Process Mechanism parameter if present. Note that this parameter
+ -- is not analyzed, and must not be analyzed since it is semantic
+ -- nonsense, so we get it in exactly as the parser left it.
- -- Note: some of the simple identifier cases were handled in par-prag,
- -- but it is harmless (and more straightforward) to simply handle all
- -- cases here, even if it means we repeat a bit of work in some cases.
+ if Present (Arg_Mechanism) then
+ declare
+ Formal : Entity_Id;
+ Massoc : Node_Id;
+ Mname : Node_Id;
+ Choice : Node_Id;
- procedure Process_Restrictions_Or_Restriction_Warnings
- (Warn : Boolean)
- is
- Arg : Node_Id;
- R_Id : Restriction_Id;
- Id : Name_Id;
- Expr : Node_Id;
- Val : Uint;
+ begin
+ -- A single mechanism association without a formal parameter
+ -- name is parsed as a parenthesized expression. All other
+ -- cases are parsed as aggregates, so we rewrite the single
+ -- parameter case as an aggregate for consistency.
- procedure Check_Unit_Name (N : Node_Id);
- -- Checks unit name parameter for No_Dependence. Returns if it has
- -- an appropriate form, otherwise raises pragma argument error.
+ if Nkind (Arg_Mechanism) /= N_Aggregate
+ and then Paren_Count (Arg_Mechanism) = 1
+ then
+ Rewrite (Arg_Mechanism,
+ Make_Aggregate (Sloc (Arg_Mechanism),
+ Expressions => New_List (
+ Relocate_Node (Arg_Mechanism))));
+ end if;
- ---------------------
- -- Check_Unit_Name --
- ---------------------
+ -- Case of only mechanism name given, applies to all formals
- procedure Check_Unit_Name (N : Node_Id) is
- begin
- if Nkind (N) = N_Selected_Component then
- Check_Unit_Name (Prefix (N));
- Check_Unit_Name (Selector_Name (N));
+ if Nkind (Arg_Mechanism) /= N_Aggregate then
+ Formal := First_Formal (Ent);
+ while Present (Formal) loop
+ Set_Mechanism_Value (Formal, Arg_Mechanism);
+ Next_Formal (Formal);
+ end loop;
- elsif Nkind (N) = N_Identifier then
- return;
+ -- Case of list of mechanism associations given
- else
- Error_Pragma_Arg
- ("wrong form for unit name for No_Dependence", N);
- end if;
- end Check_Unit_Name;
+ else
+ if Null_Record_Present (Arg_Mechanism) then
+ Error_Pragma_Arg
+ ("inappropriate form for Mechanism parameter",
+ Arg_Mechanism);
+ end if;
- -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
+ -- Deal with positional ones first
- begin
- -- Ignore all Restrictions pragma in CodePeer mode
+ Formal := First_Formal (Ent);
- if CodePeer_Mode then
- return;
- end if;
+ if Present (Expressions (Arg_Mechanism)) then
+ Mname := First (Expressions (Arg_Mechanism));
+ while Present (Mname) loop
+ if No (Formal) then
+ Error_Pragma_Arg
+ ("too many mechanism associations", Mname);
+ end if;
- Check_Ada_83_Warning;
- Check_At_Least_N_Arguments (1);
- Check_Valid_Configuration_Pragma;
+ Set_Mechanism_Value (Formal, Mname);
+ Next_Formal (Formal);
+ Next (Mname);
+ end loop;
+ end if;
- Arg := Arg1;
- while Present (Arg) loop
- Id := Chars (Arg);
- Expr := Get_Pragma_Arg (Arg);
+ -- Deal with named entries
- -- Case of no restriction identifier present
+ if Present (Component_Associations (Arg_Mechanism)) then
+ Massoc := First (Component_Associations (Arg_Mechanism));
+ while Present (Massoc) loop
+ Choice := First (Choices (Massoc));
- if Id = No_Name then
- if Nkind (Expr) /= N_Identifier then
- Error_Pragma_Arg
- ("invalid form for restriction", Arg);
- end if;
+ if Nkind (Choice) /= N_Identifier
+ or else Present (Next (Choice))
+ then
+ Error_Pragma_Arg
+ ("incorrect form for mechanism association",
+ Massoc);
+ end if;
- R_Id :=
- Get_Restriction_Id
- (Process_Restriction_Synonyms (Expr));
+ Formal := First_Formal (Ent);
+ loop
+ if No (Formal) then
+ Error_Pragma_Arg
+ ("parameter name & not present", Choice);
+ end if;
- if R_Id not in All_Boolean_Restrictions then
- Error_Msg_Name_1 := Pname;
- Error_Msg_N
- ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
+ if Chars (Choice) = Chars (Formal) then
+ Set_Mechanism_Value
+ (Formal, Expression (Massoc));
- -- Check for possible misspelling
+ -- Set entity on identifier (needed by ASIS)
- for J in Restriction_Id loop
- declare
- Rnm : constant String := Restriction_Id'Image (J);
+ Set_Entity (Choice, Formal);
- begin
- Name_Buffer (1 .. Rnm'Length) := Rnm;
- Name_Len := Rnm'Length;
- Set_Casing (All_Lower_Case);
+ exit;
+ end if;
- if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
- Set_Casing
- (Identifier_Casing (Current_Source_File));
- Error_Msg_String (1 .. Rnm'Length) :=
- Name_Buffer (1 .. Name_Len);
- Error_Msg_Strlen := Rnm'Length;
- Error_Msg_N -- CODEFIX
- ("\possible misspelling of ""~""",
- Get_Pragma_Arg (Arg));
- exit;
- end if;
- end;
- end loop;
+ Next_Formal (Formal);
+ end loop;
+
+ Next (Massoc);
+ end loop;
+ end if;
+ end if;
+ end;
+ end if;
+
+ -- Process First_Optional_Parameter argument if present. We have
+ -- already checked that this is only allowed for the Import case.
+
+ if Present (Arg_First_Optional_Parameter) then
+ if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
+ Error_Pragma_Arg
+ ("first optional parameter must be formal parameter name",
+ Arg_First_Optional_Parameter);
+ end if;
- raise Pragma_Exit;
+ Formal := First_Formal (Ent);
+ loop
+ if No (Formal) then
+ Error_Pragma_Arg
+ ("specified formal parameter& not found",
+ Arg_First_Optional_Parameter);
end if;
- if Implementation_Restriction (R_Id) then
- Check_Restriction (No_Implementation_Restrictions, Arg);
- end if;
+ exit when Chars (Formal) =
+ Chars (Arg_First_Optional_Parameter);
- -- Special processing for No_Elaboration_Code restriction
+ Next_Formal (Formal);
+ end loop;
- if R_Id = No_Elaboration_Code then
+ Set_First_Optional_Parameter (Ent, Formal);
- -- Restriction is only recognized within a configuration
- -- pragma file, or within a unit of the main extended
- -- program. Note: the test for Main_Unit is needed to
- -- properly include the case of configuration pragma files.
+ -- Check specified and all remaining formals have right form
- if not (Current_Sem_Unit = Main_Unit
- or else In_Extended_Main_Source_Unit (N))
- then
- return;
+ while Present (Formal) loop
+ if Ekind (Formal) /= E_In_Parameter then
+ Error_Msg_NE
+ ("optional formal& is not of mode in!",
+ Arg_First_Optional_Parameter, Formal);
- -- Don't allow in a subunit unless already specified in
- -- body or spec.
+ else
+ Dval := Default_Value (Formal);
- elsif Nkind (Parent (N)) = N_Compilation_Unit
- and then Nkind (Unit (Parent (N))) = N_Subunit
- and then not Restriction_Active (No_Elaboration_Code)
- then
- Error_Msg_N
- ("invalid specification of ""No_Elaboration_Code""",
- N);
- Error_Msg_N
- ("\restriction cannot be specified in a subunit", N);
- Error_Msg_N
- ("\unless also specified in body or spec", N);
- return;
+ if No (Dval) then
+ Error_Msg_NE
+ ("optional formal& does not have default value!",
+ Arg_First_Optional_Parameter, Formal);
- -- If we have a No_Elaboration_Code pragma that we
- -- accept, then it needs to be added to the configuration
- -- restrcition set so that we get proper application to
- -- other units in the main extended source as required.
+ elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
+ null;
else
- Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
+ Error_Msg_FE
+ ("default value for optional formal& is non-static!",
+ Arg_First_Optional_Parameter, Formal);
end if;
end if;
- -- If this is a warning, then set the warning unless we already
- -- have a real restriction active (we never want a warning to
- -- override a real restriction).
+ Set_Is_Optional_Parameter (Formal);
+ Next_Formal (Formal);
+ end loop;
+ end if;
+ end Process_Extended_Import_Export_Subprogram_Pragma;
- if Warn then
- if not Restriction_Active (R_Id) then
- Set_Restriction (R_Id, N);
- Restriction_Warnings (R_Id) := True;
- end if;
+ --------------------------
+ -- Process_Generic_List --
+ --------------------------
- -- If real restriction case, then set it and make sure that the
- -- restriction warning flag is off, since a real restriction
- -- always overrides a warning.
+ procedure Process_Generic_List is
+ Arg : Node_Id;
+ Exp : Node_Id;
- else
- Set_Restriction (R_Id, N);
- Restriction_Warnings (R_Id) := False;
- end if;
+ begin
+ Check_No_Identifiers;
+ Check_At_Least_N_Arguments (1);
- -- Check for obsolescent restrictions in Ada 2005 mode
+ Arg := Arg1;
+ while Present (Arg) loop
+ Exp := Get_Pragma_Arg (Arg);
+ Analyze (Exp);
- if not Warn
- and then Ada_Version >= Ada_2005
- and then (R_Id = No_Asynchronous_Control
- or else
- R_Id = No_Unchecked_Deallocation
- or else
- R_Id = No_Unchecked_Conversion)
- then
- Check_Restriction (No_Obsolescent_Features, N);
- end if;
+ if not Is_Entity_Name (Exp)
+ or else
+ (not Is_Generic_Instance (Entity (Exp))
+ and then
+ not Is_Generic_Unit (Entity (Exp)))
+ then
+ Error_Pragma_Arg
+ ("pragma% argument must be name of generic unit/instance",
+ Arg);
+ end if;
- -- A very special case that must be processed here: pragma
- -- Restrictions (No_Exceptions) turns off all run-time
- -- checking. This is a bit dubious in terms of the formal
- -- language definition, but it is what is intended by RM
- -- H.4(12). Restriction_Warnings never affects generated code
- -- so this is done only in the real restriction case.
+ Next (Arg);
+ end loop;
+ end Process_Generic_List;
- -- Atomic_Synchronization is not a real check, so it is not
- -- affected by this processing).
+ ------------------------------------
+ -- Process_Import_Predefined_Type --
+ ------------------------------------
- if R_Id = No_Exceptions and then not Warn then
- for J in Scope_Suppress.Suppress'Range loop
- if J /= Atomic_Synchronization then
- Scope_Suppress.Suppress (J) := True;
- end if;
- end loop;
- end if;
+ procedure Process_Import_Predefined_Type is
+ Loc : constant Source_Ptr := Sloc (N);
+ Elmt : Elmt_Id;
+ Ftyp : Node_Id := Empty;
+ Decl : Node_Id;
+ Def : Node_Id;
+ Nam : Name_Id;
- -- Case of No_Dependence => unit-name. Note that the parser
- -- already made the necessary entry in the No_Dependence table.
+ begin
+ String_To_Name_Buffer (Strval (Expression (Arg3)));
+ Nam := Name_Find;
- elsif Id = Name_No_Dependence then
- Check_Unit_Name (Expr);
+ Elmt := First_Elmt (Predefined_Float_Types);
+ while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
+ Next_Elmt (Elmt);
+ end loop;
- -- Case of No_Specification_Of_Aspect => Identifier.
+ Ftyp := Node (Elmt);
- elsif Id = Name_No_Specification_Of_Aspect then
- declare
- A_Id : Aspect_Id;
+ if Present (Ftyp) then
- begin
- if Nkind (Expr) /= N_Identifier then
- A_Id := No_Aspect;
- else
- A_Id := Get_Aspect_Id (Chars (Expr));
- end if;
+ -- Don't build a derived type declaration, because predefined C
+ -- types have no declaration anywhere, so cannot really be named.
+ -- Instead build a full type declaration, starting with an
+ -- appropriate type definition is built
- if A_Id = No_Aspect then
- Error_Pragma_Arg ("invalid restriction name", Arg);
- else
- Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
- end if;
- end;
+ if Is_Floating_Point_Type (Ftyp) then
+ Def := Make_Floating_Point_Definition (Loc,
+ Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
+ Make_Real_Range_Specification (Loc,
+ Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
+ Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
- elsif Id = Name_No_Use_Of_Attribute then
- if Nkind (Expr) /= N_Identifier
- or else not Is_Attribute_Name (Chars (Expr))
- then
- Error_Msg_N ("unknown attribute name?", Expr);
+ -- Should never have a predefined type we cannot handle
- else
- Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
- end if;
+ else
+ raise Program_Error;
+ end if;
- elsif Id = Name_No_Use_Of_Pragma then
- if Nkind (Expr) /= N_Identifier
- or else not Is_Pragma_Name (Chars (Expr))
- then
- Error_Msg_N ("unknown pragma name?", Expr);
+ -- Build and insert a Full_Type_Declaration, which will be
+ -- analyzed as soon as this list entry has been analyzed.
- else
- Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
- end if;
+ Decl := Make_Full_Type_Declaration (Loc,
+ Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
+ Type_Definition => Def);
- -- All other cases of restriction identifier present
+ Insert_After (N, Decl);
+ Mark_Rewrite_Insertion (Decl);
- else
- R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
- Analyze_And_Resolve (Expr, Any_Integer);
+ else
+ Error_Pragma_Arg ("no matching type found for pragma%",
+ Arg2);
+ end if;
+ end Process_Import_Predefined_Type;
+
+ ---------------------------------
+ -- Process_Import_Or_Interface --
+ ---------------------------------
+
+ procedure Process_Import_Or_Interface is
+ C : Convention_Id;
+ Def_Id : Entity_Id;
+ Hom_Id : Entity_Id;
+
+ begin
+ Process_Convention (C, Def_Id);
+ Kill_Size_Check_Code (Def_Id);
+ Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
+
+ if Ekind_In (Def_Id, E_Variable, E_Constant) then
+
+ -- We do not permit Import to apply to a renaming declaration
+
+ if Present (Renamed_Object (Def_Id)) then
+ Error_Pragma_Arg
+ ("pragma% not allowed for object renaming", Arg2);
+
+ -- User initialization is not allowed for imported object, but
+ -- the object declaration may contain a default initialization,
+ -- that will be discarded. Note that an explicit initialization
+ -- only counts if it comes from source, otherwise it is simply
+ -- the code generator making an implicit initialization explicit.
+
+ elsif Present (Expression (Parent (Def_Id)))
+ and then Comes_From_Source (Expression (Parent (Def_Id)))
+ then
+ Error_Msg_Sloc := Sloc (Def_Id);
+ Error_Pragma_Arg
+ ("no initialization allowed for declaration of& #",
+ "\imported entities cannot be initialized (RM B.1(24))",
+ Arg2);
+
+ else
+ Set_Imported (Def_Id);
+ Process_Interface_Name (Def_Id, Arg3, Arg4);
- if R_Id not in All_Parameter_Restrictions then
- Error_Pragma_Arg
- ("invalid restriction parameter identifier", Arg);
+ -- Note that we do not set Is_Public here. That's because we
+ -- only want to set it if there is no address clause, and we
+ -- don't know that yet, so we delay that processing till
+ -- freeze time.
- elsif not Is_OK_Static_Expression (Expr) then
- Flag_Non_Static_Expr
- ("value must be static expression!", Expr);
- raise Pragma_Exit;
+ -- pragma Import completes deferred constants
- elsif not Is_Integer_Type (Etype (Expr))
- or else Expr_Value (Expr) < 0
- then
- Error_Pragma_Arg
- ("value must be non-negative integer", Arg);
+ if Ekind (Def_Id) = E_Constant then
+ Set_Has_Completion (Def_Id);
end if;
- -- Restriction pragma is active
-
- Val := Expr_Value (Expr);
+ -- It is not possible to import a constant of an unconstrained
+ -- array type (e.g. string) because there is no simple way to
+ -- write a meaningful subtype for it.
- if not UI_Is_In_Int_Range (Val) then
- Error_Pragma_Arg
- ("pragma ignored, value too large??", Arg);
+ if Is_Array_Type (Etype (Def_Id))
+ and then not Is_Constrained (Etype (Def_Id))
+ then
+ Error_Msg_NE
+ ("imported constant& must have a constrained subtype",
+ N, Def_Id);
end if;
+ end if;
- -- Warning case. If the real restriction is active, then we
- -- ignore the request, since warning never overrides a real
- -- restriction. Otherwise we set the proper warning. Note that
- -- this circuit sets the warning again if it is already set,
- -- which is what we want, since the constant may have changed.
+ elsif Is_Subprogram (Def_Id)
+ or else Is_Generic_Subprogram (Def_Id)
+ then
+ -- If the name is overloaded, pragma applies to all of the denoted
+ -- entities in the same declarative part, unless the pragma comes
+ -- from an aspect specification.
- if Warn then
- if not Restriction_Active (R_Id) then
- Set_Restriction
- (R_Id, N, Integer (UI_To_Int (Val)));
- Restriction_Warnings (R_Id) := True;
- end if;
+ Hom_Id := Def_Id;
+ while Present (Hom_Id) loop
- -- Real restriction case, set restriction and make sure warning
- -- flag is off since real restriction always overrides warning.
+ Def_Id := Get_Base_Subprogram (Hom_Id);
- else
- Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
- Restriction_Warnings (R_Id) := False;
- end if;
- end if;
+ -- Ignore inherited subprograms because the pragma will apply
+ -- to the parent operation, which is the one called.
- Next (Arg);
- end loop;
- end Process_Restrictions_Or_Restriction_Warnings;
+ if Is_Overloadable (Def_Id)
+ and then Present (Alias (Def_Id))
+ then
+ null;
- ---------------------------------
- -- Process_Suppress_Unsuppress --
- ---------------------------------
+ -- If it is not a subprogram, it must be in an outer scope and
+ -- pragma does not apply.
- -- Note: this procedure makes entries in the check suppress data
- -- structures managed by Sem. See spec of package Sem for full
- -- details on how we handle recording of check suppression.
+ elsif not Is_Subprogram (Def_Id)
+ and then not Is_Generic_Subprogram (Def_Id)
+ then
+ null;
- procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
- C : Check_Id;
- E_Id : Node_Id;
- E : Entity_Id;
+ -- The pragma does not apply to primitives of interfaces
- In_Package_Spec : constant Boolean :=
- Is_Package_Or_Generic_Package (Current_Scope)
- and then not In_Package_Body (Current_Scope);
+ elsif Is_Dispatching_Operation (Def_Id)
+ and then Present (Find_Dispatching_Type (Def_Id))
+ and then Is_Interface (Find_Dispatching_Type (Def_Id))
+ then
+ null;
- procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
- -- Used to suppress a single check on the given entity
+ -- Verify that the homonym is in the same declarative part (not
+ -- just the same scope). If the pragma comes from an aspect
+ -- specification we know that it is part of the declaration.
- --------------------------------
- -- Suppress_Unsuppress_Echeck --
- --------------------------------
+ elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
+ and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
+ and then not From_Aspect_Specification (N)
+ then
+ exit;
- procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
- begin
- -- Check for error of trying to set atomic synchronization for
- -- a non-atomic variable.
+ else
+ Set_Imported (Def_Id);
- if C = Atomic_Synchronization
- and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
- then
- Error_Msg_N
- ("pragma & requires atomic type or variable",
- Pragma_Identifier (Original_Node (N)));
- end if;
+ -- Reject an Import applied to an abstract subprogram
- Set_Checks_May_Be_Suppressed (E);
+ if Is_Subprogram (Def_Id)
+ and then Is_Abstract_Subprogram (Def_Id)
+ then
+ Error_Msg_Sloc := Sloc (Def_Id);
+ Error_Msg_NE
+ ("cannot import abstract subprogram& declared#",
+ Arg2, Def_Id);
+ end if;
- if In_Package_Spec then
- Push_Global_Suppress_Stack_Entry
- (Entity => E,
- Check => C,
- Suppress => Suppress_Case);
- else
- Push_Local_Suppress_Stack_Entry
- (Entity => E,
- Check => C,
- Suppress => Suppress_Case);
- end if;
+ -- Special processing for Convention_Intrinsic
- -- If this is a first subtype, and the base type is distinct,
- -- then also set the suppress flags on the base type.
+ if C = Convention_Intrinsic then
- if Is_First_Subtype (E) and then Etype (E) /= E then
- Suppress_Unsuppress_Echeck (Etype (E), C);
- end if;
- end Suppress_Unsuppress_Echeck;
+ -- Link_Name argument not allowed for intrinsic
- -- Start of processing for Process_Suppress_Unsuppress
+ Check_No_Link_Name;
- begin
- -- Ignore pragma Suppress/Unsuppress in CodePeer and Alfa modes on
- -- user code: we want to generate checks for analysis purposes, as
- -- set respectively by -gnatC and -gnatd.F
+ Set_Is_Intrinsic_Subprogram (Def_Id);
- if (CodePeer_Mode or Alfa_Mode) and then Comes_From_Source (N) then
- return;
- end if;
+ -- If no external name is present, then check that this
+ -- is a valid intrinsic subprogram. If an external name
+ -- is present, then this is handled by the back end.
- -- Suppress/Unsuppress can appear as a configuration pragma, or in a
- -- declarative part or a package spec (RM 11.5(5)).
+ if No (Arg3) then
+ Check_Intrinsic_Subprogram
+ (Def_Id, Get_Pragma_Arg (Arg2));
+ end if;
+ end if;
- if not Is_Configuration_Pragma then
- Check_Is_In_Decl_Part_Or_Package_Spec;
- end if;
+ -- All interfaced procedures need an external symbol created
+ -- for them since they are always referenced from another
+ -- object file.
- Check_At_Least_N_Arguments (1);
- Check_At_Most_N_Arguments (2);
- Check_No_Identifier (Arg1);
- Check_Arg_Is_Identifier (Arg1);
+ Set_Is_Public (Def_Id);
- C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
+ -- Verify that the subprogram does not have a completion
+ -- through a renaming declaration. For other completions the
+ -- pragma appears as a too late representation.
- if C = No_Check_Id then
- Error_Pragma_Arg
- ("argument of pragma% is not valid check name", Arg1);
- end if;
+ declare
+ Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
- if Arg_Count = 1 then
+ begin
+ if Present (Decl)
+ and then Nkind (Decl) = N_Subprogram_Declaration
+ and then Present (Corresponding_Body (Decl))
+ and then Nkind (Unit_Declaration_Node
+ (Corresponding_Body (Decl))) =
+ N_Subprogram_Renaming_Declaration
+ then
+ Error_Msg_Sloc := Sloc (Def_Id);
+ Error_Msg_NE
+ ("cannot import&, renaming already provided for "
+ & "declaration #", N, Def_Id);
+ end if;
+ end;
- -- Make an entry in the local scope suppress table. This is the
- -- table that directly shows the current value of the scope
- -- suppress check for any check id value.
+ Set_Has_Completion (Def_Id);
+ Process_Interface_Name (Def_Id, Arg3, Arg4);
+ end if;
- if C = All_Checks then
+ if Is_Compilation_Unit (Hom_Id) then
- -- For All_Checks, we set all specific predefined checks with
- -- the exception of Elaboration_Check, which is handled
- -- specially because of not wanting All_Checks to have the
- -- effect of deactivating static elaboration order processing.
- -- Atomic_Synchronization is also not affected, since this is
- -- not a real check.
+ -- Its possible homonyms are not affected by the pragma.
+ -- Such homonyms might be present in the context of other
+ -- units being compiled.
- for J in Scope_Suppress.Suppress'Range loop
- if J /= Elaboration_Check
- and then
- J /= Atomic_Synchronization
- then
- Scope_Suppress.Suppress (J) := Suppress_Case;
- end if;
- end loop;
+ exit;
- -- If not All_Checks, and predefined check, then set appropriate
- -- scope entry. Note that we will set Elaboration_Check if this
- -- is explicitly specified. Atomic_Synchronization is allowed
- -- only if internally generated and entity is atomic.
+ elsif From_Aspect_Specification (N) then
+ exit;
- elsif C in Predefined_Check_Id
- and then (not Comes_From_Source (N)
- or else C /= Atomic_Synchronization)
- then
- Scope_Suppress.Suppress (C) := Suppress_Case;
- end if;
+ else
+ Hom_Id := Homonym (Hom_Id);
+ end if;
+ end loop;
- -- Also make an entry in the Local_Entity_Suppress table
+ -- When the convention is Java or CIL, we also allow Import to be
+ -- given for packages, generic packages, exceptions, record
+ -- components, and access to subprograms.
- Push_Local_Suppress_Stack_Entry
- (Entity => Empty,
- Check => C,
- Suppress => Suppress_Case);
+ elsif (C = Convention_Java or else C = Convention_CIL)
+ and then
+ (Is_Package_Or_Generic_Package (Def_Id)
+ or else Ekind (Def_Id) = E_Exception
+ or else Ekind (Def_Id) = E_Access_Subprogram_Type
+ or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
+ then
+ Set_Imported (Def_Id);
+ Set_Is_Public (Def_Id);
+ Process_Interface_Name (Def_Id, Arg3, Arg4);
- -- Case of two arguments present, where the check is suppressed for
- -- a specified entity (given as the second argument of the pragma)
+ -- Import a CPP class
- else
- -- This is obsolescent in Ada 2005 mode
+ elsif C = Convention_CPP
+ and then (Is_Record_Type (Def_Id)
+ or else Ekind (Def_Id) = E_Incomplete_Type)
+ then
+ if Ekind (Def_Id) = E_Incomplete_Type then
+ if Present (Full_View (Def_Id)) then
+ Def_Id := Full_View (Def_Id);
- if Ada_Version >= Ada_2005 then
- Check_Restriction (No_Obsolescent_Features, Arg2);
- end if;
+ else
+ Error_Msg_N
+ ("cannot import 'C'P'P type before full declaration seen",
+ Get_Pragma_Arg (Arg2));
- Check_Optional_Identifier (Arg2, Name_On);
- E_Id := Get_Pragma_Arg (Arg2);
- Analyze (E_Id);
+ -- Although we have reported the error we decorate it as
+ -- CPP_Class to avoid reporting spurious errors
- if not Is_Entity_Name (E_Id) then
- Error_Pragma_Arg
- ("second argument of pragma% must be entity name", Arg2);
+ Set_Is_CPP_Class (Def_Id);
+ return;
+ end if;
end if;
- E := Entity (E_Id);
+ -- Types treated as CPP classes must be declared limited (note:
+ -- this used to be a warning but there is no real benefit to it
+ -- since we did effectively intend to treat the type as limited
+ -- anyway).
- if E = Any_Id then
- return;
+ if not Is_Limited_Type (Def_Id) then
+ Error_Msg_N
+ ("imported 'C'P'P type must be limited",
+ Get_Pragma_Arg (Arg2));
end if;
- -- Enforce RM 11.5(7) which requires that for a pragma that
- -- appears within a package spec, the named entity must be
- -- within the package spec. We allow the package name itself
- -- to be mentioned since that makes sense, although it is not
- -- strictly allowed by 11.5(7).
-
- if In_Package_Spec
- and then E /= Current_Scope
- and then Scope (E) /= Current_Scope
+ if Etype (Def_Id) /= Def_Id
+ and then not Is_CPP_Class (Root_Type (Def_Id))
then
- Error_Pragma_Arg
- ("entity in pragma% is not in package spec (RM 11.5(7))",
- Arg2);
+ Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
end if;
- -- Loop through homonyms. As noted below, in the case of a package
- -- spec, only homonyms within the package spec are considered.
-
- loop
- Suppress_Unsuppress_Echeck (E, C);
-
- if Is_Generic_Instance (E)
- and then Is_Subprogram (E)
- and then Present (Alias (E))
- then
- Suppress_Unsuppress_Echeck (Alias (E), C);
- end if;
+ Set_Is_CPP_Class (Def_Id);
- -- Move to next homonym if not aspect spec case
+ -- Imported CPP types must not have discriminants (because C++
+ -- classes do not have discriminants).
- exit when From_Aspect_Specification (N);
- E := Homonym (E);
- exit when No (E);
+ if Has_Discriminants (Def_Id) then
+ Error_Msg_N
+ ("imported 'C'P'P type cannot have discriminants",
+ First (Discriminant_Specifications
+ (Declaration_Node (Def_Id))));
+ end if;
- -- If we are within a package specification, the pragma only
- -- applies to homonyms in the same scope.
+ -- Check that components of imported CPP types do not have default
+ -- expressions. For private types this check is performed when the
+ -- full view is analyzed (see Process_Full_View).
- exit when In_Package_Spec
- and then Scope (E) /= Current_Scope;
- end loop;
- end if;
- end Process_Suppress_Unsuppress;
+ if not Is_Private_Type (Def_Id) then
+ Check_CPP_Type_Has_No_Defaults (Def_Id);
+ end if;
- ------------------
- -- Set_Exported --
- ------------------
+ elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
+ Check_No_Link_Name;
+ Check_Arg_Count (3);
+ Check_Arg_Is_Static_Expression (Arg3, Standard_String);
- procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
- begin
- if Is_Imported (E) then
- Error_Pragma_Arg
- ("cannot export entity& that was previously imported", Arg);
+ Process_Import_Predefined_Type;
- elsif Present (Address_Clause (E))
- and then not Relaxed_RM_Semantics
- then
+ else
Error_Pragma_Arg
- ("cannot export entity& that has an address clause", Arg);
+ ("second argument of pragma% must be object, subprogram "
+ & "or incomplete type",
+ Arg2);
end if;
- Set_Is_Exported (E);
-
- -- Generate a reference for entity explicitly, because the
- -- identifier may be overloaded and name resolution will not
- -- generate one.
+ -- If this pragma applies to a compilation unit, then the unit, which
+ -- is a subprogram, does not require (or allow) a body. We also do
+ -- not need to elaborate imported procedures.
- Generate_Reference (E, Arg);
+ if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
+ declare
+ Cunit : constant Node_Id := Parent (Parent (N));
+ begin
+ Set_Body_Required (Cunit, False);
+ end;
+ end if;
+ end Process_Import_Or_Interface;
- -- Deal with exporting non-library level entity
+ --------------------
+ -- Process_Inline --
+ --------------------
- if not Is_Library_Level_Entity (E) then
+ procedure Process_Inline (Status : Inline_Status) is
+ Assoc : Node_Id;
+ Decl : Node_Id;
+ Subp_Id : Node_Id;
+ Subp : Entity_Id;
+ Applies : Boolean;
- -- Not allowed at all for subprograms
+ Effective : Boolean := False;
+ -- Set True if inline has some effect, i.e. if there is at least one
+ -- subprogram set as inlined as a result of the use of the pragma.
- if Is_Subprogram (E) then
- Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
+ procedure Make_Inline (Subp : Entity_Id);
+ -- Subp is the defining unit name of the subprogram declaration. Set
+ -- the flag, as well as the flag in the corresponding body, if there
+ -- is one present.
- -- Otherwise set public and statically allocated
+ procedure Set_Inline_Flags (Subp : Entity_Id);
+ -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
+ -- Has_Pragma_Inline_Always for the Inline_Always case.
- else
- Set_Is_Public (E);
- Set_Is_Statically_Allocated (E);
+ function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
+ -- Returns True if it can be determined at this stage that inlining
+ -- is not possible, for example if the body is available and contains
+ -- exception handlers, we prevent inlining, since otherwise we can
+ -- get undefined symbols at link time. This function also emits a
+ -- warning if front-end inlining is enabled and the pragma appears
+ -- too late.
+ --
+ -- ??? is business with link symbols still valid, or does it relate
+ -- to front end ZCX which is being phased out ???
- -- Warn if the corresponding W flag is set and the pragma comes
- -- from source. The latter may not be true e.g. on VMS where we
- -- expand export pragmas for exception codes associated with
- -- imported or exported exceptions. We do not want to generate
- -- a warning for something that the user did not write.
+ ---------------------------
+ -- Inlining_Not_Possible --
+ ---------------------------
- if Warn_On_Export_Import
- and then Comes_From_Source (Arg)
- then
- Error_Msg_NE
- ("?x?& has been made static as a result of Export",
- Arg, E);
- Error_Msg_N
- ("\?x?this usage is non-standard and non-portable",
- Arg);
- end if;
- end if;
- end if;
+ function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
+ Decl : constant Node_Id := Unit_Declaration_Node (Subp);
+ Stats : Node_Id;
- if Warn_On_Export_Import and then Is_Type (E) then
- Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
- end if;
+ begin
+ if Nkind (Decl) = N_Subprogram_Body then
+ Stats := Handled_Statement_Sequence (Decl);
+ return Present (Exception_Handlers (Stats))
+ or else Present (At_End_Proc (Stats));
- if Warn_On_Export_Import and Inside_A_Generic then
- Error_Msg_NE
- ("all instances of& will have the same external name?x?",
- Arg, E);
- end if;
- end Set_Exported;
+ elsif Nkind (Decl) = N_Subprogram_Declaration
+ and then Present (Corresponding_Body (Decl))
+ then
+ if Front_End_Inlining
+ and then Analyzed (Corresponding_Body (Decl))
+ then
+ Error_Msg_N ("pragma appears too late, ignored??", N);
+ return True;
- ----------------------------------------------
- -- Set_Extended_Import_Export_External_Name --
- ----------------------------------------------
+ -- If the subprogram is a renaming as body, the body is just a
+ -- call to the renamed subprogram, and inlining is trivially
+ -- possible.
- procedure Set_Extended_Import_Export_External_Name
- (Internal_Ent : Entity_Id;
- Arg_External : Node_Id)
- is
- Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
- New_Name : Node_Id;
+ elsif
+ Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
+ N_Subprogram_Renaming_Declaration
+ then
+ return False;
- begin
- if No (Arg_External) then
- return;
- end if;
+ else
+ Stats :=
+ Handled_Statement_Sequence
+ (Unit_Declaration_Node (Corresponding_Body (Decl)));
- Check_Arg_Is_External_Name (Arg_External);
+ return
+ Present (Exception_Handlers (Stats))
+ or else Present (At_End_Proc (Stats));
+ end if;
- if Nkind (Arg_External) = N_String_Literal then
- if String_Length (Strval (Arg_External)) = 0 then
- return;
else
- New_Name := Adjust_External_Name_Case (Arg_External);
+ -- If body is not available, assume the best, the check is
+ -- performed again when compiling enclosing package bodies.
+
+ return False;
end if;
+ end Inlining_Not_Possible;
- elsif Nkind (Arg_External) = N_Identifier then
- New_Name := Get_Default_External_Name (Arg_External);
+ -----------------
+ -- Make_Inline --
+ -----------------
- -- Check_Arg_Is_External_Name should let through only identifiers and
- -- string literals or static string expressions (which are folded to
- -- string literals).
+ procedure Make_Inline (Subp : Entity_Id) is
+ Kind : constant Entity_Kind := Ekind (Subp);
+ Inner_Subp : Entity_Id := Subp;
- else
- raise Program_Error;
- end if;
+ begin
+ -- Ignore if bad type, avoid cascaded error
- -- If we already have an external name set (by a prior normal Import
- -- or Export pragma), then the external names must match
+ if Etype (Subp) = Any_Type then
+ Applies := True;
+ return;
- if Present (Interface_Name (Internal_Ent)) then
- Check_Matching_Internal_Names : declare
- S1 : constant String_Id := Strval (Old_Name);
- S2 : constant String_Id := Strval (New_Name);
+ -- Ignore if all inlining is suppressed
- procedure Mismatch;
- pragma No_Return (Mismatch);
- -- Called if names do not match
+ elsif Suppress_All_Inlining then
+ Applies := True;
+ return;
- --------------
- -- Mismatch --
- --------------
+ -- If inlining is not possible, for now do not treat as an error
- procedure Mismatch is
- begin
- Error_Msg_Sloc := Sloc (Old_Name);
- Error_Pragma_Arg
- ("external name does not match that given #",
- Arg_External);
- end Mismatch;
+ elsif Status /= Suppressed
+ and then Inlining_Not_Possible (Subp)
+ then
+ Applies := True;
+ return;
- -- Start of processing for Check_Matching_Internal_Names
+ -- Here we have a candidate for inlining, but we must exclude
+ -- derived operations. Otherwise we would end up trying to inline
+ -- a phantom declaration, and the result would be to drag in a
+ -- body which has no direct inlining associated with it. That
+ -- would not only be inefficient but would also result in the
+ -- backend doing cross-unit inlining in cases where it was
+ -- definitely inappropriate to do so.
- begin
- if String_Length (S1) /= String_Length (S2) then
- Mismatch;
+ -- However, a simple Comes_From_Source test is insufficient, since
+ -- we do want to allow inlining of generic instances which also do
+ -- not come from source. We also need to recognize specs generated
+ -- by the front-end for bodies that carry the pragma. Finally,
+ -- predefined operators do not come from source but are not
+ -- inlineable either.
- else
- for J in 1 .. String_Length (S1) loop
- if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
- Mismatch;
- end if;
- end loop;
- end if;
- end Check_Matching_Internal_Names;
+ elsif Is_Generic_Instance (Subp)
+ or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
+ then
+ null;
- -- Otherwise set the given name
+ elsif not Comes_From_Source (Subp)
+ and then Scope (Subp) /= Standard_Standard
+ then
+ Applies := True;
+ return;
+ end if;
- else
- Set_Encoded_Interface_Name (Internal_Ent, New_Name);
- Check_Duplicated_Export_Name (New_Name);
- end if;
- end Set_Extended_Import_Export_External_Name;
+ -- The referenced entity must either be the enclosing entity, or
+ -- an entity declared within the current open scope.
- ------------------
- -- Set_Imported --
- ------------------
+ if Present (Scope (Subp))
+ and then Scope (Subp) /= Current_Scope
+ and then Subp /= Current_Scope
+ then
+ Error_Pragma_Arg
+ ("argument of% must be entity in current scope", Assoc);
+ return;
+ end if;
- procedure Set_Imported (E : Entity_Id) is
- begin
- -- Error message if already imported or exported
+ -- Processing for procedure, operator or function. If subprogram
+ -- is aliased (as for an instance) indicate that the renamed
+ -- entity (if declared in the same unit) is inlined.
- if Is_Exported (E) or else Is_Imported (E) then
+ if Is_Subprogram (Subp) then
+ Inner_Subp := Ultimate_Alias (Inner_Subp);
- -- Error if being set Exported twice
+ if In_Same_Source_Unit (Subp, Inner_Subp) then
+ Set_Inline_Flags (Inner_Subp);
- if Is_Exported (E) then
- Error_Msg_NE ("entity& was previously exported", N, E);
+ Decl := Parent (Parent (Inner_Subp));
- -- Ignore error in CodePeer mode where we treat all imported
- -- subprograms as unknown.
+ if Nkind (Decl) = N_Subprogram_Declaration
+ and then Present (Corresponding_Body (Decl))
+ then
+ Set_Inline_Flags (Corresponding_Body (Decl));
- elsif CodePeer_Mode then
- goto OK;
+ elsif Is_Generic_Instance (Subp) then
- -- OK if Import/Interface case
+ -- Indicate that the body needs to be created for
+ -- inlining subsequent calls. The instantiation node
+ -- follows the declaration of the wrapper package
+ -- created for it.
- elsif Import_Interface_Present (N) then
- goto OK;
+ if Scope (Subp) /= Standard_Standard
+ and then
+ Need_Subprogram_Instance_Body
+ (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
+ Subp)
+ then
+ null;
+ end if;
- -- Error if being set Imported twice
+ -- Inline is a program unit pragma (RM 10.1.5) and cannot
+ -- appear in a formal part to apply to a formal subprogram.
+ -- Do not apply check within an instance or a formal package
+ -- the test will have been applied to the original generic.
- else
- Error_Msg_NE ("entity& was previously imported", N, E);
- end if;
+ elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
+ and then List_Containing (Decl) = List_Containing (N)
+ and then not In_Instance
+ then
+ Error_Msg_N
+ ("Inline cannot apply to a formal subprogram", N);
- Error_Msg_Name_1 := Pname;
- Error_Msg_N
- ("\(pragma% applies to all previous entities)", N);
+ -- If Subp is a renaming, it is the renamed entity that
+ -- will appear in any call, and be inlined. However, for
+ -- ASIS uses it is convenient to indicate that the renaming
+ -- itself is an inlined subprogram, so that some gnatcheck
+ -- rules can be applied in the absence of expansion.
- Error_Msg_Sloc := Sloc (E);
- Error_Msg_NE ("\import not allowed for& declared#", N, E);
+ elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
+ Set_Inline_Flags (Subp);
+ end if;
+ end if;
- -- Here if not previously imported or exported, OK to import
+ Applies := True;
- else
- Set_Is_Imported (E);
+ -- For a generic subprogram set flag as well, for use at the point
+ -- of instantiation, to determine whether the body should be
+ -- generated.
- -- If the entity is an object that is not at the library level,
- -- then it is statically allocated. We do not worry about objects
- -- with address clauses in this context since they are not really
- -- imported in the linker sense.
+ elsif Is_Generic_Subprogram (Subp) then
+ Set_Inline_Flags (Subp);
+ Applies := True;
- if Is_Object (E)
- and then not Is_Library_Level_Entity (E)
- and then No (Address_Clause (E))
- then
- Set_Is_Statically_Allocated (E);
- end if;
- end if;
+ -- Literals are by definition inlined
- <<OK>> null;
- end Set_Imported;
+ elsif Kind = E_Enumeration_Literal then
+ null;
- -------------------------
- -- Set_Mechanism_Value --
- -------------------------
+ -- Anything else is an error
- -- Note: the mechanism name has not been analyzed (and cannot indeed be
- -- analyzed, since it is semantic nonsense), so we get it in the exact
- -- form created by the parser.
+ else
+ Error_Pragma_Arg
+ ("expect subprogram name for pragma%", Assoc);
+ end if;
+ end Make_Inline;
- procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
- Class : Node_Id;
- Param : Node_Id;
- Mech_Name_Id : Name_Id;
+ ----------------------
+ -- Set_Inline_Flags --
+ ----------------------
- procedure Bad_Class;
- pragma No_Return (Bad_Class);
- -- Signal bad descriptor class name
+ procedure Set_Inline_Flags (Subp : Entity_Id) is
+ begin
+ -- First set the Has_Pragma_XXX flags and issue the appropriate
+ -- errors and warnings for suspicious combinations.
- procedure Bad_Mechanism;
- pragma No_Return (Bad_Mechanism);
- -- Signal bad mechanism name
+ if Prag_Id = Pragma_No_Inline then
+ if Has_Pragma_Inline_Always (Subp) then
+ Error_Msg_N
+ ("Inline_Always and No_Inline are mutually exclusive", N);
+ elsif Has_Pragma_Inline (Subp) then
+ Error_Msg_NE
+ ("Inline and No_Inline both specified for& ??",
+ N, Entity (Subp_Id));
+ end if;
- ---------------
- -- Bad_Class --
- ---------------
+ Set_Has_Pragma_No_Inline (Subp);
+ else
+ if Prag_Id = Pragma_Inline_Always then
+ if Has_Pragma_No_Inline (Subp) then
+ Error_Msg_N
+ ("Inline_Always and No_Inline are mutually exclusive",
+ N);
+ end if;
- procedure Bad_Class is
- begin
- Error_Pragma_Arg ("unrecognized descriptor class name", Class);
- end Bad_Class;
+ Set_Has_Pragma_Inline_Always (Subp);
+ else
+ if Has_Pragma_No_Inline (Subp) then
+ Error_Msg_NE
+ ("Inline and No_Inline both specified for& ??",
+ N, Entity (Subp_Id));
+ end if;
+ end if;
- -------------------------
- -- Bad_Mechanism_Value --
- -------------------------
+ if not Has_Pragma_Inline (Subp) then
+ Set_Has_Pragma_Inline (Subp);
+ Effective := True;
+ end if;
+ end if;
- procedure Bad_Mechanism is
- begin
- Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
- end Bad_Mechanism;
+ -- Then adjust the Is_Inlined flag. It can never be set if the
+ -- subprogram is subject to pragma No_Inline.
- -- Start of processing for Set_Mechanism_Value
+ case Status is
+ when Suppressed =>
+ Set_Is_Inlined (Subp, False);
+ when Disabled =>
+ null;
+ when Enabled =>
+ if not Has_Pragma_No_Inline (Subp) then
+ Set_Is_Inlined (Subp, True);
+ end if;
+ end case;
+ end Set_Inline_Flags;
+
+ -- Start of processing for Process_Inline
begin
- if Mechanism (Ent) /= Default_Mechanism then
- Error_Msg_NE
- ("mechanism for & has already been set", Mech_Name, Ent);
+ Check_No_Identifiers;
+ Check_At_Least_N_Arguments (1);
+
+ if Status = Enabled then
+ Inline_Processing_Required := True;
end if;
- -- MECHANISM_NAME ::= value | reference | descriptor |
- -- short_descriptor
+ Assoc := Arg1;
+ while Present (Assoc) loop
+ Subp_Id := Get_Pragma_Arg (Assoc);
+ Analyze (Subp_Id);
+ Applies := False;
- if Nkind (Mech_Name) = N_Identifier then
- if Chars (Mech_Name) = Name_Value then
- Set_Mechanism (Ent, By_Copy);
- return;
+ if Is_Entity_Name (Subp_Id) then
+ Subp := Entity (Subp_Id);
- elsif Chars (Mech_Name) = Name_Reference then
- Set_Mechanism (Ent, By_Reference);
- return;
+ if Subp = Any_Id then
- elsif Chars (Mech_Name) = Name_Descriptor then
- Check_VMS (Mech_Name);
+ -- If previous error, avoid cascaded errors
- -- Descriptor => Short_Descriptor if pragma was given
+ Check_Error_Detected;
+ Applies := True;
+ Effective := True;
- if Short_Descriptors then
- Set_Mechanism (Ent, By_Short_Descriptor);
else
- Set_Mechanism (Ent, By_Descriptor);
- end if;
+ Make_Inline (Subp);
- return;
+ -- For the pragma case, climb homonym chain. This is
+ -- what implements allowing the pragma in the renaming
+ -- case, with the result applying to the ancestors, and
+ -- also allows Inline to apply to all previous homonyms.
- elsif Chars (Mech_Name) = Name_Short_Descriptor then
- Check_VMS (Mech_Name);
- Set_Mechanism (Ent, By_Short_Descriptor);
- return;
+ if not From_Aspect_Specification (N) then
+ while Present (Homonym (Subp))
+ and then Scope (Homonym (Subp)) = Current_Scope
+ loop
+ Make_Inline (Homonym (Subp));
+ Subp := Homonym (Subp);
+ end loop;
+ end if;
+ end if;
+ end if;
- elsif Chars (Mech_Name) = Name_Copy then
+ if not Applies then
Error_Pragma_Arg
- ("bad mechanism name, Value assumed", Mech_Name);
+ ("inappropriate argument for pragma%", Assoc);
- else
- Bad_Mechanism;
+ elsif not Effective
+ and then Warn_On_Redundant_Constructs
+ and then not (Status = Suppressed or else Suppress_All_Inlining)
+ then
+ if Inlining_Not_Possible (Subp) then
+ Error_Msg_NE
+ ("pragma Inline for& is ignored?r?",
+ N, Entity (Subp_Id));
+ else
+ Error_Msg_NE
+ ("pragma Inline for& is redundant?r?",
+ N, Entity (Subp_Id));
+ end if;
end if;
- -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
- -- short_descriptor (CLASS_NAME)
- -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
-
- -- Note: this form is parsed as an indexed component
-
- elsif Nkind (Mech_Name) = N_Indexed_Component then
- Class := First (Expressions (Mech_Name));
-
- if Nkind (Prefix (Mech_Name)) /= N_Identifier
- or else
- not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor,
- Name_Short_Descriptor)
- or else Present (Next (Class))
- then
- Bad_Mechanism;
- else
- Mech_Name_Id := Chars (Prefix (Mech_Name));
+ Next (Assoc);
+ end loop;
+ end Process_Inline;
- -- Change Descriptor => Short_Descriptor if pragma was given
+ ----------------------------
+ -- Process_Interface_Name --
+ ----------------------------
- if Mech_Name_Id = Name_Descriptor
- and then Short_Descriptors
- then
- Mech_Name_Id := Name_Short_Descriptor;
- end if;
- end if;
+ procedure Process_Interface_Name
+ (Subprogram_Def : Entity_Id;
+ Ext_Arg : Node_Id;
+ Link_Arg : Node_Id)
+ is
+ Ext_Nam : Node_Id;
+ Link_Nam : Node_Id;
+ String_Val : String_Id;
- -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
- -- short_descriptor (Class => CLASS_NAME)
- -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
+ procedure Check_Form_Of_Interface_Name
+ (SN : Node_Id;
+ Ext_Name_Case : Boolean);
+ -- SN is a string literal node for an interface name. This routine
+ -- performs some minimal checks that the name is reasonable. In
+ -- particular that no spaces or other obviously incorrect characters
+ -- appear. This is only a warning, since any characters are allowed.
+ -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
- -- Note: this form is parsed as a function call
+ ----------------------------------
+ -- Check_Form_Of_Interface_Name --
+ ----------------------------------
- elsif Nkind (Mech_Name) = N_Function_Call then
- Param := First (Parameter_Associations (Mech_Name));
+ procedure Check_Form_Of_Interface_Name
+ (SN : Node_Id;
+ Ext_Name_Case : Boolean)
+ is
+ S : constant String_Id := Strval (Expr_Value_S (SN));
+ SL : constant Nat := String_Length (S);
+ C : Char_Code;
- if Nkind (Name (Mech_Name)) /= N_Identifier
- or else
- not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor,
- Name_Short_Descriptor)
- or else Present (Next (Param))
- or else No (Selector_Name (Param))
- or else Chars (Selector_Name (Param)) /= Name_Class
- then
- Bad_Mechanism;
- else
- Class := Explicit_Actual_Parameter (Param);
- Mech_Name_Id := Chars (Name (Mech_Name));
+ begin
+ if SL = 0 then
+ Error_Msg_N ("interface name cannot be null string", SN);
end if;
- else
- Bad_Mechanism;
- end if;
-
- -- Fall through here with Class set to descriptor class name
+ for J in 1 .. SL loop
+ C := Get_String_Char (S, J);
- Check_VMS (Mech_Name);
+ -- Look for dubious character and issue unconditional warning.
+ -- Definitely dubious if not in character range.
- if Nkind (Class) /= N_Identifier then
- Bad_Class;
+ if not In_Character_Range (C)
- elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_UBS
- then
- Set_Mechanism (Ent, By_Descriptor_UBS);
+ -- For all cases except CLI target,
+ -- commas, spaces and slashes are dubious (in CLI, we use
+ -- commas and backslashes in external names to specify
+ -- assembly version and public key, while slashes and spaces
+ -- can be used in names to mark nested classes and
+ -- valuetypes).
- elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_UBSB
- then
- Set_Mechanism (Ent, By_Descriptor_UBSB);
+ or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
+ and then (Get_Character (C) = ','
+ or else
+ Get_Character (C) = '\'))
+ or else (VM_Target /= CLI_Target
+ and then (Get_Character (C) = ' '
+ or else
+ Get_Character (C) = '/'))
+ then
+ Error_Msg
+ ("??interface name contains illegal character",
+ Sloc (SN) + Source_Ptr (J));
+ end if;
+ end loop;
+ end Check_Form_Of_Interface_Name;
- elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_UBA
- then
- Set_Mechanism (Ent, By_Descriptor_UBA);
+ -- Start of processing for Process_Interface_Name
- elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_S
- then
- Set_Mechanism (Ent, By_Descriptor_S);
+ begin
+ if No (Link_Arg) then
+ if No (Ext_Arg) then
+ if VM_Target = CLI_Target
+ and then Ekind (Subprogram_Def) = E_Package
+ and then Nkind (Parent (Subprogram_Def)) =
+ N_Package_Specification
+ and then Present (Generic_Parent (Parent (Subprogram_Def)))
+ then
+ Set_Interface_Name
+ (Subprogram_Def,
+ Interface_Name
+ (Generic_Parent (Parent (Subprogram_Def))));
+ end if;
- elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_SB
- then
- Set_Mechanism (Ent, By_Descriptor_SB);
+ return;
- elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_A
- then
- Set_Mechanism (Ent, By_Descriptor_A);
+ elsif Chars (Ext_Arg) = Name_Link_Name then
+ Ext_Nam := Empty;
+ Link_Nam := Expression (Ext_Arg);
- elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_NCA
- then
- Set_Mechanism (Ent, By_Descriptor_NCA);
+ else
+ Check_Optional_Identifier (Ext_Arg, Name_External_Name);
+ Ext_Nam := Expression (Ext_Arg);
+ Link_Nam := Empty;
+ end if;
- elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_UBS
- then
- Set_Mechanism (Ent, By_Short_Descriptor_UBS);
+ else
+ Check_Optional_Identifier (Ext_Arg, Name_External_Name);
+ Check_Optional_Identifier (Link_Arg, Name_Link_Name);
+ Ext_Nam := Expression (Ext_Arg);
+ Link_Nam := Expression (Link_Arg);
+ end if;
- elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_UBSB
- then
- Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
+ -- Check expressions for external name and link name are static
- elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_UBA
- then
- Set_Mechanism (Ent, By_Short_Descriptor_UBA);
+ if Present (Ext_Nam) then
+ Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
+ Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
- elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_S
- then
- Set_Mechanism (Ent, By_Short_Descriptor_S);
+ -- Verify that external name is not the name of a local entity,
+ -- which would hide the imported one and could lead to run-time
+ -- surprises. The problem can only arise for entities declared in
+ -- a package body (otherwise the external name is fully qualified
+ -- and will not conflict).
- elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_SB
- then
- Set_Mechanism (Ent, By_Short_Descriptor_SB);
+ declare
+ Nam : Name_Id;
+ E : Entity_Id;
+ Par : Node_Id;
- elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_A
- then
- Set_Mechanism (Ent, By_Short_Descriptor_A);
+ begin
+ if Prag_Id = Pragma_Import then
+ String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
+ Nam := Name_Find;
+ E := Entity_Id (Get_Name_Table_Info (Nam));
- elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_NCA
- then
- Set_Mechanism (Ent, By_Short_Descriptor_NCA);
+ if Nam /= Chars (Subprogram_Def)
+ and then Present (E)
+ and then not Is_Overloadable (E)
+ and then Is_Immediately_Visible (E)
+ and then not Is_Imported (E)
+ and then Ekind (Scope (E)) = E_Package
+ then
+ Par := Parent (E);
+ while Present (Par) loop
+ if Nkind (Par) = N_Package_Body then
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_NE
+ ("imported entity is hidden by & declared#",
+ Ext_Arg, E);
+ exit;
+ end if;
- else
- Bad_Class;
+ Par := Parent (Par);
+ end loop;
+ end if;
+ end if;
+ end;
end if;
- end Set_Mechanism_Value;
- --------------------------
- -- Set_Rational_Profile --
- --------------------------
+ if Present (Link_Nam) then
+ Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
+ Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
+ end if;
- -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
- -- and extension to the semantics of renaming declarations.
+ -- If there is no link name, just set the external name
- procedure Set_Rational_Profile is
- begin
- Implicit_Packing := True;
- Overriding_Renamings := True;
- Use_VADS_Size := True;
- end Set_Rational_Profile;
+ if No (Link_Nam) then
+ Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
- ---------------------------
- -- Set_Ravenscar_Profile --
- ---------------------------
+ -- For the Link_Name case, the given literal is preceded by an
+ -- asterisk, which indicates to GCC that the given name should be
+ -- taken literally, and in particular that no prepending of
+ -- underlines should occur, even in systems where this is the
+ -- normal default.
- -- The tasks to be done here are
+ else
+ Start_String;
- -- Set required policies
+ if VM_Target = No_VM then
+ Store_String_Char (Get_Char_Code ('*'));
+ end if;
- -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
- -- pragma Locking_Policy (Ceiling_Locking)
+ String_Val := Strval (Expr_Value_S (Link_Nam));
+ Store_String_Chars (String_Val);
+ Link_Nam :=
+ Make_String_Literal (Sloc (Link_Nam),
+ Strval => End_String);
+ end if;
- -- Set Detect_Blocking mode
+ -- Set the interface name. If the entity is a generic instance, use
+ -- its alias, which is the callable entity.
- -- Set required restrictions (see System.Rident for detailed list)
+ if Is_Generic_Instance (Subprogram_Def) then
+ Set_Encoded_Interface_Name
+ (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
+ else
+ Set_Encoded_Interface_Name
+ (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
+ end if;
- -- Set the No_Dependence rules
- -- No_Dependence => Ada.Asynchronous_Task_Control
- -- No_Dependence => Ada.Calendar
- -- No_Dependence => Ada.Execution_Time.Group_Budget
- -- No_Dependence => Ada.Execution_Time.Timers
- -- No_Dependence => Ada.Task_Attributes
- -- No_Dependence => System.Multiprocessors.Dispatching_Domains
+ -- We allow duplicated export names in CIL/Java, as they are always
+ -- enclosed in a namespace that differentiates them, and overloaded
+ -- entities are supported by the VM.
- procedure Set_Ravenscar_Profile (N : Node_Id) is
- Prefix_Entity : Entity_Id;
- Selector_Entity : Entity_Id;
- Prefix_Node : Node_Id;
- Node : Node_Id;
+ if Convention (Subprogram_Def) /= Convention_CIL
+ and then
+ Convention (Subprogram_Def) /= Convention_Java
+ then
+ Check_Duplicated_Export_Name (Link_Nam);
+ end if;
+ end Process_Interface_Name;
- begin
- -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
+ -----------------------------------------
+ -- Process_Interrupt_Or_Attach_Handler --
+ -----------------------------------------
- if Task_Dispatching_Policy /= ' '
- and then Task_Dispatching_Policy /= 'F'
- then
- Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
- Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
+ procedure Process_Interrupt_Or_Attach_Handler is
+ Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
+ Handler_Proc : constant Entity_Id := Entity (Arg1_X);
+ Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
- -- Set the FIFO_Within_Priorities policy, but always preserve
- -- System_Location since we like the error message with the run time
- -- name.
+ begin
+ Set_Is_Interrupt_Handler (Handler_Proc);
- else
- Task_Dispatching_Policy := 'F';
+ -- If the pragma is not associated with a handler procedure within a
+ -- protected type, then it must be for a nonprotected procedure for
+ -- the AAMP target, in which case we don't associate a representation
+ -- item with the procedure's scope.
- if Task_Dispatching_Policy_Sloc /= System_Location then
- Task_Dispatching_Policy_Sloc := Loc;
+ if Ekind (Proc_Scope) = E_Protected_Type then
+ if Prag_Id = Pragma_Interrupt_Handler
+ or else
+ Prag_Id = Pragma_Attach_Handler
+ then
+ Record_Rep_Item (Proc_Scope, N);
end if;
end if;
+ end Process_Interrupt_Or_Attach_Handler;
- -- pragma Locking_Policy (Ceiling_Locking)
+ --------------------------------------------------
+ -- Process_Restrictions_Or_Restriction_Warnings --
+ --------------------------------------------------
- if Locking_Policy /= ' '
- and then Locking_Policy /= 'C'
- then
- Error_Msg_Sloc := Locking_Policy_Sloc;
- Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
+ -- Note: some of the simple identifier cases were handled in par-prag,
+ -- but it is harmless (and more straightforward) to simply handle all
+ -- cases here, even if it means we repeat a bit of work in some cases.
- -- Set the Ceiling_Locking policy, but preserve System_Location since
- -- we like the error message with the run time name.
+ procedure Process_Restrictions_Or_Restriction_Warnings
+ (Warn : Boolean)
+ is
+ Arg : Node_Id;
+ R_Id : Restriction_Id;
+ Id : Name_Id;
+ Expr : Node_Id;
+ Val : Uint;
- else
- Locking_Policy := 'C';
+ procedure Check_Unit_Name (N : Node_Id);
+ -- Checks unit name parameter for No_Dependence. Returns if it has
+ -- an appropriate form, otherwise raises pragma argument error.
- if Locking_Policy_Sloc /= System_Location then
- Locking_Policy_Sloc := Loc;
+ ---------------------
+ -- Check_Unit_Name --
+ ---------------------
+
+ procedure Check_Unit_Name (N : Node_Id) is
+ begin
+ if Nkind (N) = N_Selected_Component then
+ Check_Unit_Name (Prefix (N));
+ Check_Unit_Name (Selector_Name (N));
+
+ elsif Nkind (N) = N_Identifier then
+ return;
+
+ else
+ Error_Pragma_Arg
+ ("wrong form for unit name for No_Dependence", N);
end if;
- end if;
+ end Check_Unit_Name;
- -- pragma Detect_Blocking
+ -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
- Detect_Blocking := True;
+ begin
+ -- Ignore all Restrictions pragma in CodePeer mode
- -- Set the corresponding restrictions
+ if CodePeer_Mode then
+ return;
+ end if;
- Set_Profile_Restrictions
- (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
+ Check_Ada_83_Warning;
+ Check_At_Least_N_Arguments (1);
+ Check_Valid_Configuration_Pragma;
- -- Set the No_Dependence restrictions
+ Arg := Arg1;
+ while Present (Arg) loop
+ Id := Chars (Arg);
+ Expr := Get_Pragma_Arg (Arg);
- -- The following No_Dependence restrictions:
- -- No_Dependence => Ada.Asynchronous_Task_Control
- -- No_Dependence => Ada.Calendar
- -- No_Dependence => Ada.Task_Attributes
- -- are already set by previous call to Set_Profile_Restrictions.
+ -- Case of no restriction identifier present
- -- Set the following restrictions which were added to Ada 2005:
- -- No_Dependence => Ada.Execution_Time.Group_Budget
- -- No_Dependence => Ada.Execution_Time.Timers
+ if Id = No_Name then
+ if Nkind (Expr) /= N_Identifier then
+ Error_Pragma_Arg
+ ("invalid form for restriction", Arg);
+ end if;
- if Ada_Version >= Ada_2005 then
- Name_Buffer (1 .. 3) := "ada";
- Name_Len := 3;
+ R_Id :=
+ Get_Restriction_Id
+ (Process_Restriction_Synonyms (Expr));
- Prefix_Entity := Make_Identifier (Loc, Name_Find);
+ if R_Id not in All_Boolean_Restrictions then
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N
+ ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
- Name_Buffer (1 .. 14) := "execution_time";
- Name_Len := 14;
+ -- Check for possible misspelling
- Selector_Entity := Make_Identifier (Loc, Name_Find);
+ for J in Restriction_Id loop
+ declare
+ Rnm : constant String := Restriction_Id'Image (J);
- Prefix_Node :=
- Make_Selected_Component
- (Sloc => Loc,
- Prefix => Prefix_Entity,
- Selector_Name => Selector_Entity);
+ begin
+ Name_Buffer (1 .. Rnm'Length) := Rnm;
+ Name_Len := Rnm'Length;
+ Set_Casing (All_Lower_Case);
- Name_Buffer (1 .. 13) := "group_budgets";
- Name_Len := 13;
+ if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
+ Set_Casing
+ (Identifier_Casing (Current_Source_File));
+ Error_Msg_String (1 .. Rnm'Length) :=
+ Name_Buffer (1 .. Name_Len);
+ Error_Msg_Strlen := Rnm'Length;
+ Error_Msg_N -- CODEFIX
+ ("\possible misspelling of ""~""",
+ Get_Pragma_Arg (Arg));
+ exit;
+ end if;
+ end;
+ end loop;
- Selector_Entity := Make_Identifier (Loc, Name_Find);
+ raise Pragma_Exit;
+ end if;
- Node :=
- Make_Selected_Component
- (Sloc => Loc,
- Prefix => Prefix_Node,
- Selector_Name => Selector_Entity);
+ if Implementation_Restriction (R_Id) then
+ Check_Restriction (No_Implementation_Restrictions, Arg);
+ end if;
- Set_Restriction_No_Dependence
- (Unit => Node,
- Warn => Treat_Restrictions_As_Warnings,
- Profile => Ravenscar);
+ -- Special processing for No_Elaboration_Code restriction
- Name_Buffer (1 .. 6) := "timers";
- Name_Len := 6;
+ if R_Id = No_Elaboration_Code then
- Selector_Entity := Make_Identifier (Loc, Name_Find);
+ -- Restriction is only recognized within a configuration
+ -- pragma file, or within a unit of the main extended
+ -- program. Note: the test for Main_Unit is needed to
+ -- properly include the case of configuration pragma files.
- Node :=
- Make_Selected_Component
- (Sloc => Loc,
- Prefix => Prefix_Node,
- Selector_Name => Selector_Entity);
+ if not (Current_Sem_Unit = Main_Unit
+ or else In_Extended_Main_Source_Unit (N))
+ then
+ return;
- Set_Restriction_No_Dependence
- (Unit => Node,
- Warn => Treat_Restrictions_As_Warnings,
- Profile => Ravenscar);
- end if;
+ -- Don't allow in a subunit unless already specified in
+ -- body or spec.
- -- Set the following restrictions which was added to Ada 2012 (see
- -- AI-0171):
- -- No_Dependence => System.Multiprocessors.Dispatching_Domains
+ elsif Nkind (Parent (N)) = N_Compilation_Unit
+ and then Nkind (Unit (Parent (N))) = N_Subunit
+ and then not Restriction_Active (No_Elaboration_Code)
+ then
+ Error_Msg_N
+ ("invalid specification of ""No_Elaboration_Code""",
+ N);
+ Error_Msg_N
+ ("\restriction cannot be specified in a subunit", N);
+ Error_Msg_N
+ ("\unless also specified in body or spec", N);
+ return;
- if Ada_Version >= Ada_2012 then
- Name_Buffer (1 .. 6) := "system";
- Name_Len := 6;
+ -- If we have a No_Elaboration_Code pragma that we
+ -- accept, then it needs to be added to the configuration
+ -- restrcition set so that we get proper application to
+ -- other units in the main extended source as required.
- Prefix_Entity := Make_Identifier (Loc, Name_Find);
+ else
+ Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
+ end if;
+ end if;
- Name_Buffer (1 .. 15) := "multiprocessors";
- Name_Len := 15;
+ -- If this is a warning, then set the warning unless we already
+ -- have a real restriction active (we never want a warning to
+ -- override a real restriction).
- Selector_Entity := Make_Identifier (Loc, Name_Find);
+ if Warn then
+ if not Restriction_Active (R_Id) then
+ Set_Restriction (R_Id, N);
+ Restriction_Warnings (R_Id) := True;
+ end if;
- Prefix_Node :=
- Make_Selected_Component
- (Sloc => Loc,
- Prefix => Prefix_Entity,
- Selector_Name => Selector_Entity);
+ -- If real restriction case, then set it and make sure that the
+ -- restriction warning flag is off, since a real restriction
+ -- always overrides a warning.
- Name_Buffer (1 .. 19) := "dispatching_domains";
- Name_Len := 19;
+ else
+ Set_Restriction (R_Id, N);
+ Restriction_Warnings (R_Id) := False;
+ end if;
- Selector_Entity := Make_Identifier (Loc, Name_Find);
+ -- Check for obsolescent restrictions in Ada 2005 mode
- Node :=
- Make_Selected_Component
- (Sloc => Loc,
- Prefix => Prefix_Node,
- Selector_Name => Selector_Entity);
+ if not Warn
+ and then Ada_Version >= Ada_2005
+ and then (R_Id = No_Asynchronous_Control
+ or else
+ R_Id = No_Unchecked_Deallocation
+ or else
+ R_Id = No_Unchecked_Conversion)
+ then
+ Check_Restriction (No_Obsolescent_Features, N);
+ end if;
- Set_Restriction_No_Dependence
- (Unit => Node,
- Warn => Treat_Restrictions_As_Warnings,
- Profile => Ravenscar);
- end if;
- end Set_Ravenscar_Profile;
+ -- A very special case that must be processed here: pragma
+ -- Restrictions (No_Exceptions) turns off all run-time
+ -- checking. This is a bit dubious in terms of the formal
+ -- language definition, but it is what is intended by RM
+ -- H.4(12). Restriction_Warnings never affects generated code
+ -- so this is done only in the real restriction case.
- ----------------
- -- S14_Pragma --
- ----------------
+ -- Atomic_Synchronization is not a real check, so it is not
+ -- affected by this processing).
- procedure S14_Pragma is
- begin
- if not Formal_Extensions then
- Error_Pragma ("pragma% requires the use of debug switch -gnatd.V");
- end if;
- end S14_Pragma;
+ if R_Id = No_Exceptions and then not Warn then
+ for J in Scope_Suppress.Suppress'Range loop
+ if J /= Atomic_Synchronization then
+ Scope_Suppress.Suppress (J) := True;
+ end if;
+ end loop;
+ end if;
- -- Start of processing for Analyze_Pragma
+ -- Case of No_Dependence => unit-name. Note that the parser
+ -- already made the necessary entry in the No_Dependence table.
- begin
- -- The following code is a defense against recursion. Not clear that
- -- this can happen legitimately, but perhaps some error situations
- -- can cause it, and we did see this recursion during testing.
+ elsif Id = Name_No_Dependence then
+ Check_Unit_Name (Expr);
- if Analyzed (N) then
- return;
- else
- Set_Analyzed (N, True);
- end if;
+ -- Case of No_Specification_Of_Aspect => Identifier.
- -- Deal with unrecognized pragma
+ elsif Id = Name_No_Specification_Of_Aspect then
+ declare
+ A_Id : Aspect_Id;
- Pname := Pragma_Name (N);
+ begin
+ if Nkind (Expr) /= N_Identifier then
+ A_Id := No_Aspect;
+ else
+ A_Id := Get_Aspect_Id (Chars (Expr));
+ end if;
- if not Is_Pragma_Name (Pname) then
- if Warn_On_Unrecognized_Pragma then
- Error_Msg_Name_1 := Pname;
- Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
+ if A_Id = No_Aspect then
+ Error_Pragma_Arg ("invalid restriction name", Arg);
+ else
+ Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
+ end if;
+ end;
- for PN in First_Pragma_Name .. Last_Pragma_Name loop
- if Is_Bad_Spelling_Of (Pname, PN) then
- Error_Msg_Name_1 := PN;
- Error_Msg_N -- CODEFIX
- ("\?g?possible misspelling of %!", Pragma_Identifier (N));
- exit;
+ elsif Id = Name_No_Use_Of_Attribute then
+ if Nkind (Expr) /= N_Identifier
+ or else not Is_Attribute_Name (Chars (Expr))
+ then
+ Error_Msg_N ("unknown attribute name?", Expr);
+
+ else
+ Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
end if;
- end loop;
- end if;
- return;
- end if;
+ elsif Id = Name_No_Use_Of_Pragma then
+ if Nkind (Expr) /= N_Identifier
+ or else not Is_Pragma_Name (Chars (Expr))
+ then
+ Error_Msg_N ("unknown pragma name?", Expr);
- -- Here to start processing for recognized pragma
+ else
+ Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
+ end if;
- Prag_Id := Get_Pragma_Id (Pname);
- Pname := Original_Name (N);
+ -- All other cases of restriction identifier present
- -- Check applicable policy. We skip this for a pragma that came from
- -- an aspect, since we already dealt with the Disable case, and we set
- -- the Is_Ignored flag at the time the aspect was analyzed.
+ else
+ R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
+ Analyze_And_Resolve (Expr, Any_Integer);
- if not From_Aspect_Specification (N) then
- Check_Applicable_Policy (N);
+ if R_Id not in All_Parameter_Restrictions then
+ Error_Pragma_Arg
+ ("invalid restriction parameter identifier", Arg);
- -- If pragma is disabled, rewrite as NULL and skip analysis
+ elsif not Is_OK_Static_Expression (Expr) then
+ Flag_Non_Static_Expr
+ ("value must be static expression!", Expr);
+ raise Pragma_Exit;
- if Is_Disabled (N) then
- Rewrite (N, Make_Null_Statement (Loc));
- Analyze (N);
- raise Pragma_Exit;
- end if;
- end if;
+ elsif not Is_Integer_Type (Etype (Expr))
+ or else Expr_Value (Expr) < 0
+ then
+ Error_Pragma_Arg
+ ("value must be non-negative integer", Arg);
+ end if;
- -- Preset arguments
+ -- Restriction pragma is active
- Arg_Count := 0;
- Arg1 := Empty;
- Arg2 := Empty;
- Arg3 := Empty;
- Arg4 := Empty;
+ Val := Expr_Value (Expr);
- if Present (Pragma_Argument_Associations (N)) then
- Arg_Count := List_Length (Pragma_Argument_Associations (N));
- Arg1 := First (Pragma_Argument_Associations (N));
+ if not UI_Is_In_Int_Range (Val) then
+ Error_Pragma_Arg
+ ("pragma ignored, value too large??", Arg);
+ end if;
- if Present (Arg1) then
- Arg2 := Next (Arg1);
+ -- Warning case. If the real restriction is active, then we
+ -- ignore the request, since warning never overrides a real
+ -- restriction. Otherwise we set the proper warning. Note that
+ -- this circuit sets the warning again if it is already set,
+ -- which is what we want, since the constant may have changed.
- if Present (Arg2) then
- Arg3 := Next (Arg2);
+ if Warn then
+ if not Restriction_Active (R_Id) then
+ Set_Restriction
+ (R_Id, N, Integer (UI_To_Int (Val)));
+ Restriction_Warnings (R_Id) := True;
+ end if;
- if Present (Arg3) then
- Arg4 := Next (Arg3);
+ -- Real restriction case, set restriction and make sure warning
+ -- flag is off since real restriction always overrides warning.
+
+ else
+ Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
+ Restriction_Warnings (R_Id) := False;
end if;
end if;
- end if;
- end if;
- Check_Restriction_No_Use_Of_Pragma (N);
+ Next (Arg);
+ end loop;
+ end Process_Restrictions_Or_Restriction_Warnings;
- -- An enumeration type defines the pragmas that are supported by the
- -- implementation. Get_Pragma_Id (in package Prag) transforms a name
- -- into the corresponding enumeration value for the following case.
+ ---------------------------------
+ -- Process_Suppress_Unsuppress --
+ ---------------------------------
- case Prag_Id is
+ -- Note: this procedure makes entries in the check suppress data
+ -- structures managed by Sem. See spec of package Sem for full
+ -- details on how we handle recording of check suppression.
- -----------------
- -- Abort_Defer --
- -----------------
+ procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
+ C : Check_Id;
+ E_Id : Node_Id;
+ E : Entity_Id;
- -- pragma Abort_Defer;
+ In_Package_Spec : constant Boolean :=
+ Is_Package_Or_Generic_Package (Current_Scope)
+ and then not In_Package_Body (Current_Scope);
- when Pragma_Abort_Defer =>
- GNAT_Pragma;
- Check_Arg_Count (0);
+ procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
+ -- Used to suppress a single check on the given entity
- -- The only required semantic processing is to check the
- -- placement. This pragma must appear at the start of the
- -- statement sequence of a handled sequence of statements.
+ --------------------------------
+ -- Suppress_Unsuppress_Echeck --
+ --------------------------------
- if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
- or else N /= First (Statements (Parent (N)))
+ procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
+ begin
+ -- Check for error of trying to set atomic synchronization for
+ -- a non-atomic variable.
+
+ if C = Atomic_Synchronization
+ and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
then
- Pragma_Misplaced;
+ Error_Msg_N
+ ("pragma & requires atomic type or variable",
+ Pragma_Identifier (Original_Node (N)));
end if;
- --------------------
- -- Abstract_State --
- --------------------
-
- -- pragma Abstract_State (ABSTRACT_STATE_LIST)
-
- -- ABSTRACT_STATE_LIST ::=
- -- null
- -- | STATE_NAME_WITH_PROPERTIES {, STATE_NAME_WITH_PROPERTIES}
+ Set_Checks_May_Be_Suppressed (E);
- -- STATE_NAME_WITH_PROPERTIES ::=
- -- STATE_NAME
- -- | (STATE_NAME with PROPERTY_LIST)
+ if In_Package_Spec then
+ Push_Global_Suppress_Stack_Entry
+ (Entity => E,
+ Check => C,
+ Suppress => Suppress_Case);
+ else
+ Push_Local_Suppress_Stack_Entry
+ (Entity => E,
+ Check => C,
+ Suppress => Suppress_Case);
+ end if;
- -- PROPERTY_LIST ::= PROPERTY {, PROPERTY}
- -- PROPERTY ::= SIMPLE_PROPERTY | NAME_VALUE_PROPERTY
+ -- If this is a first subtype, and the base type is distinct,
+ -- then also set the suppress flags on the base type.
- -- SIMPLE_PROPERTY ::= IDENTIFIER
- -- NAME_VALUE_PROPERTY ::= IDENTIFIER => EXPRESSION
+ if Is_First_Subtype (E) and then Etype (E) /= E then
+ Suppress_Unsuppress_Echeck (Etype (E), C);
+ end if;
+ end Suppress_Unsuppress_Echeck;
- -- STATE_NAME ::= DEFINING_IDENTIFIER
+ -- Start of processing for Process_Suppress_Unsuppress
- when Pragma_Abstract_State => Abstract_State : declare
- Pack_Id : Entity_Id;
+ begin
+ -- Ignore pragma Suppress/Unsuppress in CodePeer and Alfa modes on
+ -- user code: we want to generate checks for analysis purposes, as
+ -- set respectively by -gnatC and -gnatd.F
- -- Flags used to verify the consistency of states
+ if (CodePeer_Mode or Alfa_Mode) and then Comes_From_Source (N) then
+ return;
+ end if;
- Non_Null_Seen : Boolean := False;
- Null_Seen : Boolean := False;
+ -- Suppress/Unsuppress can appear as a configuration pragma, or in a
+ -- declarative part or a package spec (RM 11.5(5)).
- procedure Analyze_Abstract_State (State : Node_Id);
- -- Verify the legality of a single state declaration. Create and
- -- decorate a state abstraction entity and introduce it into the
- -- visibility chain.
+ if not Is_Configuration_Pragma then
+ Check_Is_In_Decl_Part_Or_Package_Spec;
+ end if;
- ----------------------------
- -- Analyze_Abstract_State --
- ----------------------------
+ Check_At_Least_N_Arguments (1);
+ Check_At_Most_N_Arguments (2);
+ Check_No_Identifier (Arg1);
+ Check_Arg_Is_Identifier (Arg1);
- procedure Analyze_Abstract_State (State : Node_Id) is
- procedure Check_Duplicate_Property
- (Prop : Node_Id;
- Status : in out Boolean);
- -- Flag Status denotes whether a particular property has been
- -- seen while processing a state. This routine verifies that
- -- Prop is not a duplicate property and sets the flag Status.
+ C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
- ------------------------------
- -- Check_Duplicate_Property --
- ------------------------------
+ if C = No_Check_Id then
+ Error_Pragma_Arg
+ ("argument of pragma% is not valid check name", Arg1);
+ end if;
- procedure Check_Duplicate_Property
- (Prop : Node_Id;
- Status : in out Boolean)
- is
- begin
- if Status then
- Error_Msg_N ("duplicate state property", Prop);
- end if;
+ if Arg_Count = 1 then
- Status := True;
- end Check_Duplicate_Property;
+ -- Make an entry in the local scope suppress table. This is the
+ -- table that directly shows the current value of the scope
+ -- suppress check for any check id value.
- -- Local variables
+ if C = All_Checks then
- Errors : constant Nat := Serious_Errors_Detected;
- Loc : constant Source_Ptr := Sloc (State);
- Assoc : Node_Id;
- Id : Entity_Id;
- Is_Null : Boolean := False;
- Level : Uint := Uint_0;
- Name : Name_Id;
- Prop : Node_Id;
+ -- For All_Checks, we set all specific predefined checks with
+ -- the exception of Elaboration_Check, which is handled
+ -- specially because of not wanting All_Checks to have the
+ -- effect of deactivating static elaboration order processing.
+ -- Atomic_Synchronization is also not affected, since this is
+ -- not a real check.
- -- Flags used to verify the consistency of properties
+ for J in Scope_Suppress.Suppress'Range loop
+ if J /= Elaboration_Check
+ and then
+ J /= Atomic_Synchronization
+ then
+ Scope_Suppress.Suppress (J) := Suppress_Case;
+ end if;
+ end loop;
- Input_Seen : Boolean := False;
- Integrity_Seen : Boolean := False;
- Output_Seen : Boolean := False;
- Volatile_Seen : Boolean := False;
+ -- If not All_Checks, and predefined check, then set appropriate
+ -- scope entry. Note that we will set Elaboration_Check if this
+ -- is explicitly specified. Atomic_Synchronization is allowed
+ -- only if internally generated and entity is atomic.
- -- Start of processing for Analyze_Abstract_State
+ elsif C in Predefined_Check_Id
+ and then (not Comes_From_Source (N)
+ or else C /= Atomic_Synchronization)
+ then
+ Scope_Suppress.Suppress (C) := Suppress_Case;
+ end if;
- begin
- -- A package with a null abstract state is not allowed to
- -- declare additional states.
+ -- Also make an entry in the Local_Entity_Suppress table
- if Null_Seen then
- Error_Msg_NE
- ("package & has null abstract state", State, Pack_Id);
+ Push_Local_Suppress_Stack_Entry
+ (Entity => Empty,
+ Check => C,
+ Suppress => Suppress_Case);
- -- Null states appear as internally generated entities
+ -- Case of two arguments present, where the check is suppressed for
+ -- a specified entity (given as the second argument of the pragma)
- elsif Nkind (State) = N_Null then
- Name := New_Internal_Name ('S');
- Is_Null := True;
- Null_Seen := True;
+ else
+ -- This is obsolescent in Ada 2005 mode
- -- Catch a case where a null state appears in a list of
- -- non-null states.
+ if Ada_Version >= Ada_2005 then
+ Check_Restriction (No_Obsolescent_Features, Arg2);
+ end if;
- if Non_Null_Seen then
- Error_Msg_NE
- ("package & has non-null abstract state",
- State, Pack_Id);
- end if;
+ Check_Optional_Identifier (Arg2, Name_On);
+ E_Id := Get_Pragma_Arg (Arg2);
+ Analyze (E_Id);
- -- Simple state declaration
+ if not Is_Entity_Name (E_Id) then
+ Error_Pragma_Arg
+ ("second argument of pragma% must be entity name", Arg2);
+ end if;
- elsif Nkind (State) = N_Identifier then
- Name := Chars (State);
- Non_Null_Seen := True;
+ E := Entity (E_Id);
- -- State declaration with various properties. This construct
- -- appears as an extension aggregate in the tree.
+ if E = Any_Id then
+ return;
+ end if;
- elsif Nkind (State) = N_Extension_Aggregate then
- if Nkind (Ancestor_Part (State)) = N_Identifier then
- Name := Chars (Ancestor_Part (State));
- Non_Null_Seen := True;
- else
- Error_Msg_N
- ("state name must be an identifier",
- Ancestor_Part (State));
- end if;
+ -- Enforce RM 11.5(7) which requires that for a pragma that
+ -- appears within a package spec, the named entity must be
+ -- within the package spec. We allow the package name itself
+ -- to be mentioned since that makes sense, although it is not
+ -- strictly allowed by 11.5(7).
- -- Process properties Input, Output and Volatile. Ensure
- -- that none of them appear more than once.
+ if In_Package_Spec
+ and then E /= Current_Scope
+ and then Scope (E) /= Current_Scope
+ then
+ Error_Pragma_Arg
+ ("entity in pragma% is not in package spec (RM 11.5(7))",
+ Arg2);
+ end if;
- Prop := First (Expressions (State));
- while Present (Prop) loop
- if Nkind (Prop) = N_Identifier then
- if Chars (Prop) = Name_Input then
- Check_Duplicate_Property (Prop, Input_Seen);
- elsif Chars (Prop) = Name_Output then
- Check_Duplicate_Property (Prop, Output_Seen);
- elsif Chars (Prop) = Name_Volatile then
- Check_Duplicate_Property (Prop, Volatile_Seen);
- else
- Error_Msg_N ("invalid state property", Prop);
- end if;
- else
- Error_Msg_N ("invalid state property", Prop);
- end if;
+ -- Loop through homonyms. As noted below, in the case of a package
+ -- spec, only homonyms within the package spec are considered.
- Next (Prop);
- end loop;
+ loop
+ Suppress_Unsuppress_Echeck (E, C);
- -- Volatile requires exactly one Input or Output
+ if Is_Generic_Instance (E)
+ and then Is_Subprogram (E)
+ and then Present (Alias (E))
+ then
+ Suppress_Unsuppress_Echeck (Alias (E), C);
+ end if;
- if Volatile_Seen
- and then
- ((Input_Seen and then Output_Seen) -- both
- or else
- (not Input_Seen and then not Output_Seen)) -- none
- then
- Error_Msg_N
- ("property Volatile requires exactly one Input or "
- & "Output", State);
- end if;
+ -- Move to next homonym if not aspect spec case
- -- Either Input or Output require Volatile
+ exit when From_Aspect_Specification (N);
+ E := Homonym (E);
+ exit when No (E);
- if (Input_Seen or Output_Seen)
- and then not Volatile_Seen
- then
- Error_Msg_N
- ("properties Input and Output require Volatile", State);
- end if;
+ -- If we are within a package specification, the pragma only
+ -- applies to homonyms in the same scope.
- -- State property Integrity appears as a component
- -- association.
+ exit when In_Package_Spec
+ and then Scope (E) /= Current_Scope;
+ end loop;
+ end if;
+ end Process_Suppress_Unsuppress;
- Assoc := First (Component_Associations (State));
- while Present (Assoc) loop
- Prop := First (Choices (Assoc));
- while Present (Prop) loop
- if Nkind (Prop) = N_Identifier
- and then Chars (Prop) = Name_Integrity
- then
- Check_Duplicate_Property (Prop, Integrity_Seen);
- else
- Error_Msg_N ("invalid state property", Prop);
- end if;
+ ------------------
+ -- Set_Exported --
+ ------------------
- Next (Prop);
- end loop;
+ procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
+ begin
+ if Is_Imported (E) then
+ Error_Pragma_Arg
+ ("cannot export entity& that was previously imported", Arg);
- if Nkind (Expression (Assoc)) = N_Integer_Literal then
- Level := Intval (Expression (Assoc));
- else
- Error_Msg_N
- ("integrity level must be an integer literal",
- Expression (Assoc));
- end if;
+ elsif Present (Address_Clause (E))
+ and then not Relaxed_RM_Semantics
+ then
+ Error_Pragma_Arg
+ ("cannot export entity& that has an address clause", Arg);
+ end if;
- Next (Assoc);
- end loop;
+ Set_Is_Exported (E);
- -- Any other attempt to declare a state is erroneous
+ -- Generate a reference for entity explicitly, because the
+ -- identifier may be overloaded and name resolution will not
+ -- generate one.
- else
- Error_Msg_N ("malformed abstract state declaration", State);
- end if;
+ Generate_Reference (E, Arg);
- -- Do not generate a state abstraction entity if it was not
- -- properly declared.
+ -- Deal with exporting non-library level entity
- if Serious_Errors_Detected > Errors then
- return;
- end if;
+ if not Is_Library_Level_Entity (E) then
- -- The generated state abstraction reuses the same characters
- -- from the original state declaration. Decorate the entity.
+ -- Not allowed at all for subprograms
- Id := Make_Defining_Identifier (Loc, New_External_Name (Name));
- Set_Comes_From_Source (Id, not Is_Null);
- Set_Parent (Id, State);
- Set_Ekind (Id, E_Abstract_State);
- Set_Etype (Id, Standard_Void_Type);
- Set_Integrity_Level (Id, Level);
- Set_Refined_State (Id, Empty);
+ if Is_Subprogram (E) then
+ Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
- -- Every non-null state must be nameable and resolvable the
- -- same way a constant is.
+ -- Otherwise set public and statically allocated
- if not Is_Null then
- Push_Scope (Pack_Id);
- Enter_Name (Id);
- Pop_Scope;
- end if;
+ else
+ Set_Is_Public (E);
+ Set_Is_Statically_Allocated (E);
- -- Associate the state with its related package
+ -- Warn if the corresponding W flag is set and the pragma comes
+ -- from source. The latter may not be true e.g. on VMS where we
+ -- expand export pragmas for exception codes associated with
+ -- imported or exported exceptions. We do not want to generate
+ -- a warning for something that the user did not write.
- if No (Abstract_States (Pack_Id)) then
- Set_Abstract_States (Pack_Id, New_Elmt_List);
+ if Warn_On_Export_Import
+ and then Comes_From_Source (Arg)
+ then
+ Error_Msg_NE
+ ("?x?& has been made static as a result of Export",
+ Arg, E);
+ Error_Msg_N
+ ("\?x?this usage is non-standard and non-portable",
+ Arg);
end if;
+ end if;
+ end if;
- Append_Elmt (Id, Abstract_States (Pack_Id));
- end Analyze_Abstract_State;
+ if Warn_On_Export_Import and then Is_Type (E) then
+ Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
+ end if;
- -- Local variables
+ if Warn_On_Export_Import and Inside_A_Generic then
+ Error_Msg_NE
+ ("all instances of& will have the same external name?x?",
+ Arg, E);
+ end if;
+ end Set_Exported;
- Par : Node_Id;
- State : Node_Id;
+ ----------------------------------------------
+ -- Set_Extended_Import_Export_External_Name --
+ ----------------------------------------------
- -- Start of processing for Abstract_State
+ procedure Set_Extended_Import_Export_External_Name
+ (Internal_Ent : Entity_Id;
+ Arg_External : Node_Id)
+ is
+ Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
+ New_Name : Node_Id;
- begin
- GNAT_Pragma;
- S14_Pragma;
- Check_Arg_Count (1);
+ begin
+ if No (Arg_External) then
+ return;
+ end if;
- -- Ensure the proper placement of the pragma. Abstract states must
- -- be associated with a package declaration.
+ Check_Arg_Is_External_Name (Arg_External);
- if From_Aspect_Specification (N) then
- Par := Parent (Corresponding_Aspect (N));
+ if Nkind (Arg_External) = N_String_Literal then
+ if String_Length (Strval (Arg_External)) = 0 then
+ return;
else
- Par := Parent (Parent (N));
+ New_Name := Adjust_External_Name_Case (Arg_External);
end if;
- if Nkind (Par) = N_Compilation_Unit then
- Par := Unit (Par);
- end if;
+ elsif Nkind (Arg_External) = N_Identifier then
+ New_Name := Get_Default_External_Name (Arg_External);
- if Nkind (Par) /= N_Package_Declaration then
- Pragma_Misplaced;
- return;
- end if;
+ -- Check_Arg_Is_External_Name should let through only identifiers and
+ -- string literals or static string expressions (which are folded to
+ -- string literals).
- Pack_Id := Defining_Entity (Par);
- State := Expression (Arg1);
+ else
+ raise Program_Error;
+ end if;
- -- Multiple abstract states appear as an aggregate
+ -- If we already have an external name set (by a prior normal Import
+ -- or Export pragma), then the external names must match
- if Nkind (State) = N_Aggregate then
- State := First (Expressions (State));
- while Present (State) loop
- Analyze_Abstract_State (State);
+ if Present (Interface_Name (Internal_Ent)) then
+ Check_Matching_Internal_Names : declare
+ S1 : constant String_Id := Strval (Old_Name);
+ S2 : constant String_Id := Strval (New_Name);
- Next (State);
- end loop;
+ procedure Mismatch;
+ pragma No_Return (Mismatch);
+ -- Called if names do not match
- -- Various forms of a single abstract state. Note that these may
- -- include malformed state declarations.
+ --------------
+ -- Mismatch --
+ --------------
- else
- Analyze_Abstract_State (State);
- end if;
- end Abstract_State;
+ procedure Mismatch is
+ begin
+ Error_Msg_Sloc := Sloc (Old_Name);
+ Error_Pragma_Arg
+ ("external name does not match that given #",
+ Arg_External);
+ end Mismatch;
- ------------
- -- Ada_83 --
- ------------
+ -- Start of processing for Check_Matching_Internal_Names
- -- pragma Ada_83;
+ begin
+ if String_Length (S1) /= String_Length (S2) then
+ Mismatch;
- -- Note: this pragma also has some specific processing in Par.Prag
- -- because we want to set the Ada version mode during parsing.
+ else
+ for J in 1 .. String_Length (S1) loop
+ if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
+ Mismatch;
+ end if;
+ end loop;
+ end if;
+ end Check_Matching_Internal_Names;
- when Pragma_Ada_83 =>
- GNAT_Pragma;
- Check_Arg_Count (0);
+ -- Otherwise set the given name
- -- We really should check unconditionally for proper configuration
- -- pragma placement, since we really don't want mixed Ada modes
- -- within a single unit, and the GNAT reference manual has always
- -- said this was a configuration pragma, but we did not check and
- -- are hesitant to add the check now.
+ else
+ Set_Encoded_Interface_Name (Internal_Ent, New_Name);
+ Check_Duplicated_Export_Name (New_Name);
+ end if;
+ end Set_Extended_Import_Export_External_Name;
- -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
- -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
- -- or Ada 2012 mode.
+ ------------------
+ -- Set_Imported --
+ ------------------
- if Ada_Version >= Ada_2005 then
- Check_Valid_Configuration_Pragma;
- end if;
+ procedure Set_Imported (E : Entity_Id) is
+ begin
+ -- Error message if already imported or exported
- -- Now set Ada 83 mode
+ if Is_Exported (E) or else Is_Imported (E) then
- Ada_Version := Ada_83;
- Ada_Version_Explicit := Ada_Version;
+ -- Error if being set Exported twice
- ------------
- -- Ada_95 --
- ------------
+ if Is_Exported (E) then
+ Error_Msg_NE ("entity& was previously exported", N, E);
- -- pragma Ada_95;
+ -- Ignore error in CodePeer mode where we treat all imported
+ -- subprograms as unknown.
- -- Note: this pragma also has some specific processing in Par.Prag
- -- because we want to set the Ada 83 version mode during parsing.
+ elsif CodePeer_Mode then
+ goto OK;
- when Pragma_Ada_95 =>
- GNAT_Pragma;
- Check_Arg_Count (0);
+ -- OK if Import/Interface case
- -- We really should check unconditionally for proper configuration
- -- pragma placement, since we really don't want mixed Ada modes
- -- within a single unit, and the GNAT reference manual has always
- -- said this was a configuration pragma, but we did not check and
- -- are hesitant to add the check now.
+ elsif Import_Interface_Present (N) then
+ goto OK;
- -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
- -- or Ada 95, so we must check if we are in Ada 2005 mode.
+ -- Error if being set Imported twice
- if Ada_Version >= Ada_2005 then
- Check_Valid_Configuration_Pragma;
+ else
+ Error_Msg_NE ("entity& was previously imported", N, E);
end if;
- -- Now set Ada 95 mode
-
- Ada_Version := Ada_95;
- Ada_Version_Explicit := Ada_Version;
-
- ---------------------
- -- Ada_05/Ada_2005 --
- ---------------------
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N
+ ("\(pragma% applies to all previous entities)", N);
- -- pragma Ada_05;
- -- pragma Ada_05 (LOCAL_NAME);
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_NE ("\import not allowed for& declared#", N, E);
- -- pragma Ada_2005;
- -- pragma Ada_2005 (LOCAL_NAME):
+ -- Here if not previously imported or exported, OK to import
- -- Note: these pragmas also have some specific processing in Par.Prag
- -- because we want to set the Ada 2005 version mode during parsing.
+ else
+ Set_Is_Imported (E);
- when Pragma_Ada_05 | Pragma_Ada_2005 => declare
- E_Id : Node_Id;
+ -- If the entity is an object that is not at the library level,
+ -- then it is statically allocated. We do not worry about objects
+ -- with address clauses in this context since they are not really
+ -- imported in the linker sense.
- begin
- GNAT_Pragma;
+ if Is_Object (E)
+ and then not Is_Library_Level_Entity (E)
+ and then No (Address_Clause (E))
+ then
+ Set_Is_Statically_Allocated (E);
+ end if;
+ end if;
- if Arg_Count = 1 then
- Check_Arg_Is_Local_Name (Arg1);
- E_Id := Get_Pragma_Arg (Arg1);
+ <<OK>> null;
+ end Set_Imported;
- if Etype (E_Id) = Any_Type then
- return;
- end if;
+ -------------------------
+ -- Set_Mechanism_Value --
+ -------------------------
- Set_Is_Ada_2005_Only (Entity (E_Id));
- Record_Rep_Item (Entity (E_Id), N);
+ -- Note: the mechanism name has not been analyzed (and cannot indeed be
+ -- analyzed, since it is semantic nonsense), so we get it in the exact
+ -- form created by the parser.
- else
- Check_Arg_Count (0);
+ procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
+ Class : Node_Id;
+ Param : Node_Id;
+ Mech_Name_Id : Name_Id;
- -- For Ada_2005 we unconditionally enforce the documented
- -- configuration pragma placement, since we do not want to
- -- tolerate mixed modes in a unit involving Ada 2005. That
- -- would cause real difficulties for those cases where there
- -- are incompatibilities between Ada 95 and Ada 2005.
+ procedure Bad_Class;
+ pragma No_Return (Bad_Class);
+ -- Signal bad descriptor class name
- Check_Valid_Configuration_Pragma;
+ procedure Bad_Mechanism;
+ pragma No_Return (Bad_Mechanism);
+ -- Signal bad mechanism name
- -- Now set appropriate Ada mode
+ ---------------
+ -- Bad_Class --
+ ---------------
- Ada_Version := Ada_2005;
- Ada_Version_Explicit := Ada_2005;
- end if;
- end;
+ procedure Bad_Class is
+ begin
+ Error_Pragma_Arg ("unrecognized descriptor class name", Class);
+ end Bad_Class;
- ---------------------
- -- Ada_12/Ada_2012 --
- ---------------------
+ -------------------------
+ -- Bad_Mechanism_Value --
+ -------------------------
- -- pragma Ada_12;
- -- pragma Ada_12 (LOCAL_NAME);
+ procedure Bad_Mechanism is
+ begin
+ Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
+ end Bad_Mechanism;
- -- pragma Ada_2012;
- -- pragma Ada_2012 (LOCAL_NAME):
+ -- Start of processing for Set_Mechanism_Value
- -- Note: these pragmas also have some specific processing in Par.Prag
- -- because we want to set the Ada 2012 version mode during parsing.
+ begin
+ if Mechanism (Ent) /= Default_Mechanism then
+ Error_Msg_NE
+ ("mechanism for & has already been set", Mech_Name, Ent);
+ end if;
- when Pragma_Ada_12 | Pragma_Ada_2012 => declare
- E_Id : Node_Id;
+ -- MECHANISM_NAME ::= value | reference | descriptor |
+ -- short_descriptor
- begin
- GNAT_Pragma;
+ if Nkind (Mech_Name) = N_Identifier then
+ if Chars (Mech_Name) = Name_Value then
+ Set_Mechanism (Ent, By_Copy);
+ return;
- if Arg_Count = 1 then
- Check_Arg_Is_Local_Name (Arg1);
- E_Id := Get_Pragma_Arg (Arg1);
+ elsif Chars (Mech_Name) = Name_Reference then
+ Set_Mechanism (Ent, By_Reference);
+ return;
- if Etype (E_Id) = Any_Type then
- return;
- end if;
+ elsif Chars (Mech_Name) = Name_Descriptor then
+ Check_VMS (Mech_Name);
- Set_Is_Ada_2012_Only (Entity (E_Id));
- Record_Rep_Item (Entity (E_Id), N);
+ -- Descriptor => Short_Descriptor if pragma was given
- else
- Check_Arg_Count (0);
+ if Short_Descriptors then
+ Set_Mechanism (Ent, By_Short_Descriptor);
+ else
+ Set_Mechanism (Ent, By_Descriptor);
+ end if;
- -- For Ada_2012 we unconditionally enforce the documented
- -- configuration pragma placement, since we do not want to
- -- tolerate mixed modes in a unit involving Ada 2012. That
- -- would cause real difficulties for those cases where there
- -- are incompatibilities between Ada 95 and Ada 2012. We could
- -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
+ return;
- Check_Valid_Configuration_Pragma;
+ elsif Chars (Mech_Name) = Name_Short_Descriptor then
+ Check_VMS (Mech_Name);
+ Set_Mechanism (Ent, By_Short_Descriptor);
+ return;
- -- Now set appropriate Ada mode
+ elsif Chars (Mech_Name) = Name_Copy then
+ Error_Pragma_Arg
+ ("bad mechanism name, Value assumed", Mech_Name);
- Ada_Version := Ada_2012;
- Ada_Version_Explicit := Ada_2012;
+ else
+ Bad_Mechanism;
end if;
- end;
- ----------------------
- -- All_Calls_Remote --
- ----------------------
+ -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
+ -- short_descriptor (CLASS_NAME)
+ -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
- -- pragma All_Calls_Remote [(library_package_NAME)];
+ -- Note: this form is parsed as an indexed component
- when Pragma_All_Calls_Remote => All_Calls_Remote : declare
- Lib_Entity : Entity_Id;
+ elsif Nkind (Mech_Name) = N_Indexed_Component then
+ Class := First (Expressions (Mech_Name));
- begin
- Check_Ada_83_Warning;
- Check_Valid_Library_Unit_Pragma;
+ if Nkind (Prefix (Mech_Name)) /= N_Identifier
+ or else
+ not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor,
+ Name_Short_Descriptor)
+ or else Present (Next (Class))
+ then
+ Bad_Mechanism;
+ else
+ Mech_Name_Id := Chars (Prefix (Mech_Name));
- if Nkind (N) = N_Null_Statement then
- return;
+ -- Change Descriptor => Short_Descriptor if pragma was given
+
+ if Mech_Name_Id = Name_Descriptor
+ and then Short_Descriptors
+ then
+ Mech_Name_Id := Name_Short_Descriptor;
+ end if;
end if;
- Lib_Entity := Find_Lib_Unit_Name;
+ -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
+ -- short_descriptor (Class => CLASS_NAME)
+ -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
- -- This pragma should only apply to a RCI unit (RM E.2.3(23))
+ -- Note: this form is parsed as a function call
- if Present (Lib_Entity)
- and then not Debug_Flag_U
+ elsif Nkind (Mech_Name) = N_Function_Call then
+ Param := First (Parameter_Associations (Mech_Name));
+
+ if Nkind (Name (Mech_Name)) /= N_Identifier
+ or else
+ not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor,
+ Name_Short_Descriptor)
+ or else Present (Next (Param))
+ or else No (Selector_Name (Param))
+ or else Chars (Selector_Name (Param)) /= Name_Class
then
- if not Is_Remote_Call_Interface (Lib_Entity) then
- Error_Pragma ("pragma% only apply to rci unit");
+ Bad_Mechanism;
+ else
+ Class := Explicit_Actual_Parameter (Param);
+ Mech_Name_Id := Chars (Name (Mech_Name));
+ end if;
- -- Set flag for entity of the library unit
+ else
+ Bad_Mechanism;
+ end if;
- else
- Set_Has_All_Calls_Remote (Lib_Entity);
- end if;
+ -- Fall through here with Class set to descriptor class name
- end if;
- end All_Calls_Remote;
+ Check_VMS (Mech_Name);
- --------------
- -- Annotate --
- --------------
+ if Nkind (Class) /= N_Identifier then
+ Bad_Class;
- -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
- -- ARG ::= NAME | EXPRESSION
+ elsif Mech_Name_Id = Name_Descriptor
+ and then Chars (Class) = Name_UBS
+ then
+ Set_Mechanism (Ent, By_Descriptor_UBS);
- -- The first two arguments are by convention intended to refer to an
- -- external tool and a tool-specific function. These arguments are
- -- not analyzed.
+ elsif Mech_Name_Id = Name_Descriptor
+ and then Chars (Class) = Name_UBSB
+ then
+ Set_Mechanism (Ent, By_Descriptor_UBSB);
- when Pragma_Annotate => Annotate : declare
- Arg : Node_Id;
- Exp : Node_Id;
+ elsif Mech_Name_Id = Name_Descriptor
+ and then Chars (Class) = Name_UBA
+ then
+ Set_Mechanism (Ent, By_Descriptor_UBA);
- begin
- GNAT_Pragma;
- Check_At_Least_N_Arguments (1);
- Check_Arg_Is_Identifier (Arg1);
- Check_No_Identifiers;
- Store_Note (N);
+ elsif Mech_Name_Id = Name_Descriptor
+ and then Chars (Class) = Name_S
+ then
+ Set_Mechanism (Ent, By_Descriptor_S);
- -- Second parameter is optional, it is never analyzed
+ elsif Mech_Name_Id = Name_Descriptor
+ and then Chars (Class) = Name_SB
+ then
+ Set_Mechanism (Ent, By_Descriptor_SB);
- if No (Arg2) then
- null;
+ elsif Mech_Name_Id = Name_Descriptor
+ and then Chars (Class) = Name_A
+ then
+ Set_Mechanism (Ent, By_Descriptor_A);
- -- Here if we have a second parameter
+ elsif Mech_Name_Id = Name_Descriptor
+ and then Chars (Class) = Name_NCA
+ then
+ Set_Mechanism (Ent, By_Descriptor_NCA);
- else
- -- Second parameter must be identifier
+ elsif Mech_Name_Id = Name_Short_Descriptor
+ and then Chars (Class) = Name_UBS
+ then
+ Set_Mechanism (Ent, By_Short_Descriptor_UBS);
- Check_Arg_Is_Identifier (Arg2);
+ elsif Mech_Name_Id = Name_Short_Descriptor
+ and then Chars (Class) = Name_UBSB
+ then
+ Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
- -- Process remaining parameters if any
+ elsif Mech_Name_Id = Name_Short_Descriptor
+ and then Chars (Class) = Name_UBA
+ then
+ Set_Mechanism (Ent, By_Short_Descriptor_UBA);
- Arg := Next (Arg2);
- while Present (Arg) loop
- Exp := Get_Pragma_Arg (Arg);
- Analyze (Exp);
+ elsif Mech_Name_Id = Name_Short_Descriptor
+ and then Chars (Class) = Name_S
+ then
+ Set_Mechanism (Ent, By_Short_Descriptor_S);
- if Is_Entity_Name (Exp) then
- null;
+ elsif Mech_Name_Id = Name_Short_Descriptor
+ and then Chars (Class) = Name_SB
+ then
+ Set_Mechanism (Ent, By_Short_Descriptor_SB);
- -- For string literals, we assume Standard_String as the
- -- type, unless the string contains wide or wide_wide
- -- characters.
+ elsif Mech_Name_Id = Name_Short_Descriptor
+ and then Chars (Class) = Name_A
+ then
+ Set_Mechanism (Ent, By_Short_Descriptor_A);
- elsif Nkind (Exp) = N_String_Literal then
- if Has_Wide_Wide_Character (Exp) then
- Resolve (Exp, Standard_Wide_Wide_String);
- elsif Has_Wide_Character (Exp) then
- Resolve (Exp, Standard_Wide_String);
- else
- Resolve (Exp, Standard_String);
- end if;
+ elsif Mech_Name_Id = Name_Short_Descriptor
+ and then Chars (Class) = Name_NCA
+ then
+ Set_Mechanism (Ent, By_Short_Descriptor_NCA);
- elsif Is_Overloaded (Exp) then
- Error_Pragma_Arg
- ("ambiguous argument for pragma%", Exp);
+ else
+ Bad_Class;
+ end if;
+ end Set_Mechanism_Value;
- else
- Resolve (Exp);
- end if;
+ --------------------------
+ -- Set_Rational_Profile --
+ --------------------------
- Next (Arg);
- end loop;
- end if;
- end Annotate;
+ -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
+ -- and extension to the semantics of renaming declarations.
- ---------------------------
- -- Assert/Assert_And_Cut --
- ---------------------------
+ procedure Set_Rational_Profile is
+ begin
+ Implicit_Packing := True;
+ Overriding_Renamings := True;
+ Use_VADS_Size := True;
+ end Set_Rational_Profile;
+
+ ---------------------------
+ -- Set_Ravenscar_Profile --
+ ---------------------------
- -- pragma Assert
- -- ( [Check => ] Boolean_EXPRESSION
- -- [, [Message =>] Static_String_EXPRESSION]);
+ -- The tasks to be done here are
- -- pragma Assert_And_Cut
- -- ( [Check => ] Boolean_EXPRESSION
- -- [, [Message =>] Static_String_EXPRESSION]);
+ -- Set required policies
- when Pragma_Assert | Pragma_Assert_And_Cut => Assert : declare
- Expr : Node_Id;
- Newa : List_Id;
+ -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
+ -- pragma Locking_Policy (Ceiling_Locking)
- begin
- if Prag_Id = Pragma_Assert then
- Ada_2005_Pragma;
- else -- Pragma_Assert_And_Cut
- GNAT_Pragma;
- S14_Pragma;
- end if;
+ -- Set Detect_Blocking mode
- Check_At_Least_N_Arguments (1);
- Check_At_Most_N_Arguments (2);
- Check_Arg_Order ((Name_Check, Name_Message));
- Check_Optional_Identifier (Arg1, Name_Check);
+ -- Set required restrictions (see System.Rident for detailed list)
- -- We treat pragma Assert[_And_Cut] as equivalent to:
+ -- Set the No_Dependence rules
+ -- No_Dependence => Ada.Asynchronous_Task_Control
+ -- No_Dependence => Ada.Calendar
+ -- No_Dependence => Ada.Execution_Time.Group_Budget
+ -- No_Dependence => Ada.Execution_Time.Timers
+ -- No_Dependence => Ada.Task_Attributes
+ -- No_Dependence => System.Multiprocessors.Dispatching_Domains
- -- pragma Check (Assert[_And_Cut], condition [, msg]);
+ procedure Set_Ravenscar_Profile (N : Node_Id) is
+ Prefix_Entity : Entity_Id;
+ Selector_Entity : Entity_Id;
+ Prefix_Node : Node_Id;
+ Node : Node_Id;
- -- So rewrite pragma in this manner, transfer the message
- -- argument if present, and analyze the result
+ begin
+ -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
- -- Pragma Assert_And_Cut is treated exactly like pragma Assert by
- -- the frontend. Formal verification tools may use it to "cut" the
- -- paths through the code, to make verification tractable. When
- -- dealing with a semantically analyzed tree, the information that
- -- a Check node N corresponds to a source Assert_And_Cut pragma
- -- can be retrieved from the pragma kind of Original_Node(N).
+ if Task_Dispatching_Policy /= ' '
+ and then Task_Dispatching_Policy /= 'F'
+ then
+ Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
+ Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
- Expr := Get_Pragma_Arg (Arg1);
- Newa := New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression => Make_Identifier (Loc, Pname)),
- Make_Pragma_Argument_Association (Sloc (Expr),
- Expression => Expr));
+ -- Set the FIFO_Within_Priorities policy, but always preserve
+ -- System_Location since we like the error message with the run time
+ -- name.
- if Arg_Count > 1 then
- Check_Optional_Identifier (Arg2, Name_Message);
- Append_To (Newa, New_Copy_Tree (Arg2));
+ else
+ Task_Dispatching_Policy := 'F';
+
+ if Task_Dispatching_Policy_Sloc /= System_Location then
+ Task_Dispatching_Policy_Sloc := Loc;
end if;
+ end if;
- Rewrite (N,
- Make_Pragma (Loc,
- Chars => Name_Check,
- Pragma_Argument_Associations => Newa));
- Analyze (N);
- end Assert;
+ -- pragma Locking_Policy (Ceiling_Locking)
- ----------------------
- -- Assertion_Policy --
- ----------------------
+ if Locking_Policy /= ' '
+ and then Locking_Policy /= 'C'
+ then
+ Error_Msg_Sloc := Locking_Policy_Sloc;
+ Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
- -- pragma Assertion_Policy (POLICY_IDENTIFIER);
+ -- Set the Ceiling_Locking policy, but preserve System_Location since
+ -- we like the error message with the run time name.
- -- The following form is Ada 2012 only, but we allow it in all modes
+ else
+ Locking_Policy := 'C';
- -- Pragma Assertion_Policy (
- -- ASSERTION_KIND => POLICY_IDENTIFIER
- -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
+ if Locking_Policy_Sloc /= System_Location then
+ Locking_Policy_Sloc := Loc;
+ end if;
+ end if;
- -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
+ -- pragma Detect_Blocking
- -- RM_ASSERTION_KIND ::= Assert |
- -- Static_Predicate |
- -- Dynamic_Predicate |
- -- Pre |
- -- Pre'Class |
- -- Post |
- -- Post'Class |
- -- Type_Invariant |
- -- Type_Invariant'Class
+ Detect_Blocking := True;
- -- ID_ASSERTION_KIND ::= Assert_And_Cut |
- -- Assume |
- -- Contract_Cases |
- -- Debug |
- -- Loop_Invariant |
- -- Loop_Variant |
- -- Postcondition |
- -- Precondition |
- -- Predicate |
- -- Statement_Assertions
- --
- -- Note: The RM_ASSERTION_KIND list is language-defined, and the
- -- ID_ASSERTION_KIND list contains implementation-defined additions
- -- recognized by GNAT. The effect is to control the behavior of
- -- identically named aspects and pragmas, depending on the specified
- -- policy identifier:
+ -- Set the corresponding restrictions
- -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
+ Set_Profile_Restrictions
+ (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
- -- Note: Check and Ignore are language-defined. Disable is a GNAT
- -- implementation defined addition that results in totally ignoring
- -- the corresponding assertion. If Disable is specified, then the
- -- argument of the assertion is not even analyzed. This is useful
- -- when the aspect/pragma argument references entities in a with'ed
- -- package that is replaced by a dummy package in the final build.
+ -- Set the No_Dependence restrictions
- -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
- -- and Type_Invariant'Class were recognized by the parser and
- -- transformed into references to the special internal identifiers
- -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
- -- processing is required here.
+ -- The following No_Dependence restrictions:
+ -- No_Dependence => Ada.Asynchronous_Task_Control
+ -- No_Dependence => Ada.Calendar
+ -- No_Dependence => Ada.Task_Attributes
+ -- are already set by previous call to Set_Profile_Restrictions.
- when Pragma_Assertion_Policy => Assertion_Policy : declare
- LocP : Source_Ptr;
- Policy : Node_Id;
- Arg : Node_Id;
- Kind : Name_Id;
+ -- Set the following restrictions which were added to Ada 2005:
+ -- No_Dependence => Ada.Execution_Time.Group_Budget
+ -- No_Dependence => Ada.Execution_Time.Timers
- begin
- Ada_2005_Pragma;
+ if Ada_Version >= Ada_2005 then
+ Name_Buffer (1 .. 3) := "ada";
+ Name_Len := 3;
- -- This can always appear as a configuration pragma
+ Prefix_Entity := Make_Identifier (Loc, Name_Find);
- if Is_Configuration_Pragma then
- null;
+ Name_Buffer (1 .. 14) := "execution_time";
+ Name_Len := 14;
- -- It can also appear in a declarative part or package spec in Ada
- -- 2012 mode. We allow this in other modes, but in that case we
- -- consider that we have an Ada 2012 pragma on our hands.
+ Selector_Entity := Make_Identifier (Loc, Name_Find);
- else
- Check_Is_In_Decl_Part_Or_Package_Spec;
- Ada_2012_Pragma;
- end if;
+ Prefix_Node :=
+ Make_Selected_Component
+ (Sloc => Loc,
+ Prefix => Prefix_Entity,
+ Selector_Name => Selector_Entity);
- -- One argument case with no identifier (first form above)
+ Name_Buffer (1 .. 13) := "group_budgets";
+ Name_Len := 13;
- if Arg_Count = 1
- and then (Nkind (Arg1) /= N_Pragma_Argument_Association
- or else Chars (Arg1) = No_Name)
- then
- Check_Arg_Is_One_Of
- (Arg1, Name_Check, Name_Disable, Name_Ignore);
+ Selector_Entity := Make_Identifier (Loc, Name_Find);
- -- Treat one argument Assertion_Policy as equivalent to:
+ Node :=
+ Make_Selected_Component
+ (Sloc => Loc,
+ Prefix => Prefix_Node,
+ Selector_Name => Selector_Entity);
- -- pragma Check_Policy (Assertion, policy)
+ Set_Restriction_No_Dependence
+ (Unit => Node,
+ Warn => Treat_Restrictions_As_Warnings,
+ Profile => Ravenscar);
- -- So rewrite pragma in that manner and link on to the chain
- -- of Check_Policy pragmas, marking the pragma as analyzed.
+ Name_Buffer (1 .. 6) := "timers";
+ Name_Len := 6;
- Policy := Get_Pragma_Arg (Arg1);
+ Selector_Entity := Make_Identifier (Loc, Name_Find);
- Rewrite (N,
- Make_Pragma (Loc,
- Chars => Name_Check_Policy,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression => Make_Identifier (Loc, Name_Assertion)),
+ Node :=
+ Make_Selected_Component
+ (Sloc => Loc,
+ Prefix => Prefix_Node,
+ Selector_Name => Selector_Entity);
- Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_Identifier (Sloc (Policy), Chars (Policy))))));
- Analyze (N);
+ Set_Restriction_No_Dependence
+ (Unit => Node,
+ Warn => Treat_Restrictions_As_Warnings,
+ Profile => Ravenscar);
+ end if;
- -- Here if we have two or more arguments
+ -- Set the following restrictions which was added to Ada 2012 (see
+ -- AI-0171):
+ -- No_Dependence => System.Multiprocessors.Dispatching_Domains
- else
- Check_At_Least_N_Arguments (1);
- Ada_2012_Pragma;
+ if Ada_Version >= Ada_2012 then
+ Name_Buffer (1 .. 6) := "system";
+ Name_Len := 6;
- -- Loop through arguments
+ Prefix_Entity := Make_Identifier (Loc, Name_Find);
- Arg := Arg1;
- while Present (Arg) loop
- LocP := Sloc (Arg);
+ Name_Buffer (1 .. 15) := "multiprocessors";
+ Name_Len := 15;
+
+ Selector_Entity := Make_Identifier (Loc, Name_Find);
+
+ Prefix_Node :=
+ Make_Selected_Component
+ (Sloc => Loc,
+ Prefix => Prefix_Entity,
+ Selector_Name => Selector_Entity);
+
+ Name_Buffer (1 .. 19) := "dispatching_domains";
+ Name_Len := 19;
- -- Kind must be specified
+ Selector_Entity := Make_Identifier (Loc, Name_Find);
- if Nkind (Arg) /= N_Pragma_Argument_Association
- or else Chars (Arg) = No_Name
- then
- Error_Pragma_Arg
- ("missing assertion kind for pragma%", Arg);
- end if;
+ Node :=
+ Make_Selected_Component
+ (Sloc => Loc,
+ Prefix => Prefix_Node,
+ Selector_Name => Selector_Entity);
- -- Check Kind and Policy have allowed forms
+ Set_Restriction_No_Dependence
+ (Unit => Node,
+ Warn => Treat_Restrictions_As_Warnings,
+ Profile => Ravenscar);
+ end if;
+ end Set_Ravenscar_Profile;
- Kind := Chars (Arg);
+ ----------------
+ -- S14_Pragma --
+ ----------------
- if not Is_Valid_Assertion_Kind (Kind) then
- Error_Pragma_Arg
- ("invalid assertion kind for pragma%", Arg);
- end if;
+ procedure S14_Pragma is
+ begin
+ if not Formal_Extensions then
+ Error_Pragma ("pragma% requires the use of debug switch -gnatd.V");
+ end if;
+ end S14_Pragma;
- Check_Arg_Is_One_Of
- (Arg, Name_Check, Name_Disable, Name_Ignore);
+ -- Start of processing for Analyze_Pragma
- -- We rewrite the Assertion_Policy pragma as a series of
- -- Check_Policy pragmas:
+ begin
+ -- The following code is a defense against recursion. Not clear that
+ -- this can happen legitimately, but perhaps some error situations
+ -- can cause it, and we did see this recursion during testing.
- -- Check_Policy (Kind, Policy);
+ if Analyzed (N) then
+ return;
+ else
+ Set_Analyzed (N, True);
+ end if;
- Insert_Action (N,
- Make_Pragma (LocP,
- Chars => Name_Check_Policy,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (LocP,
- Expression => Make_Identifier (LocP, Kind)),
- Make_Pragma_Argument_Association (LocP,
- Expression => Get_Pragma_Arg (Arg)))));
+ -- Deal with unrecognized pragma
- Arg := Next (Arg);
- end loop;
+ Pname := Pragma_Name (N);
- -- Rewrite the Assertion_Policy pragma as null since we have
- -- now inserted all the equivalent Check pragmas.
+ if not Is_Pragma_Name (Pname) then
+ if Warn_On_Unrecognized_Pragma then
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
- Rewrite (N, Make_Null_Statement (Loc));
- Analyze (N);
- end if;
- end Assertion_Policy;
+ for PN in First_Pragma_Name .. Last_Pragma_Name loop
+ if Is_Bad_Spelling_Of (Pname, PN) then
+ Error_Msg_Name_1 := PN;
+ Error_Msg_N -- CODEFIX
+ ("\?g?possible misspelling of %!", Pragma_Identifier (N));
+ exit;
+ end if;
+ end loop;
+ end if;
- ------------
- -- Assume --
- ------------
+ return;
+ end if;
- -- pragma Assume (boolean_EXPRESSION);
+ -- Here to start processing for recognized pragma
- when Pragma_Assume => Assume : declare
- begin
- GNAT_Pragma;
- S14_Pragma;
- Check_Arg_Count (1);
+ Prag_Id := Get_Pragma_Id (Pname);
+ Pname := Original_Name (N);
- -- Pragma Assume is transformed into pragma Check in the following
- -- manner:
+ -- Check applicable policy. We skip this for a pragma that came from
+ -- an aspect, since we already dealt with the Disable case, and we set
+ -- the Is_Ignored flag at the time the aspect was analyzed.
- -- pragma Check (Assume, Expr);
+ if not From_Aspect_Specification (N) then
+ Check_Applicable_Policy (N);
- Rewrite (N,
- Make_Pragma (Loc,
- Chars => Name_Check,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression => Make_Identifier (Loc, Name_Assume)),
+ -- If pragma is disabled, rewrite as NULL and skip analysis
- Make_Pragma_Argument_Association (Loc,
- Expression => Relocate_Node (Expression (Arg1))))));
+ if Is_Disabled (N) then
+ Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
- end Assume;
+ raise Pragma_Exit;
+ end if;
+ end if;
- ------------------------------
- -- Assume_No_Invalid_Values --
- ------------------------------
+ -- Preset arguments
- -- pragma Assume_No_Invalid_Values (On | Off);
+ Arg_Count := 0;
+ Arg1 := Empty;
+ Arg2 := Empty;
+ Arg3 := Empty;
+ Arg4 := Empty;
- when Pragma_Assume_No_Invalid_Values =>
- GNAT_Pragma;
- Check_Valid_Configuration_Pragma;
- Check_Arg_Count (1);
- Check_No_Identifiers;
- Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
+ if Present (Pragma_Argument_Associations (N)) then
+ Arg_Count := List_Length (Pragma_Argument_Associations (N));
+ Arg1 := First (Pragma_Argument_Associations (N));
- if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
- Assume_No_Invalid_Values := True;
- else
- Assume_No_Invalid_Values := False;
+ if Present (Arg1) then
+ Arg2 := Next (Arg1);
+
+ if Present (Arg2) then
+ Arg3 := Next (Arg2);
+
+ if Present (Arg3) then
+ Arg4 := Next (Arg3);
+ end if;
end if;
+ end if;
+ end if;
- --------------------------
- -- Attribute_Definition --
- --------------------------
+ Check_Restriction_No_Use_Of_Pragma (N);
- -- pragma Attribute_Definition
- -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
- -- [Entity =>] LOCAL_NAME,
- -- [Expression =>] EXPRESSION | NAME);
+ -- An enumeration type defines the pragmas that are supported by the
+ -- implementation. Get_Pragma_Id (in package Prag) transforms a name
+ -- into the corresponding enumeration value for the following case.
- when Pragma_Attribute_Definition => Attribute_Definition : declare
- Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
- Aname : Name_Id;
+ case Prag_Id is
- begin
+ -----------------
+ -- Abort_Defer --
+ -----------------
+
+ -- pragma Abort_Defer;
+
+ when Pragma_Abort_Defer =>
GNAT_Pragma;
- Check_Arg_Count (3);
- Check_Optional_Identifier (Arg1, "attribute");
- Check_Optional_Identifier (Arg2, "entity");
- Check_Optional_Identifier (Arg3, "expression");
+ Check_Arg_Count (0);
- if Nkind (Attribute_Designator) /= N_Identifier then
- Error_Msg_N ("attribute name expected", Attribute_Designator);
- return;
- end if;
+ -- The only required semantic processing is to check the
+ -- placement. This pragma must appear at the start of the
+ -- statement sequence of a handled sequence of statements.
- Check_Arg_Is_Local_Name (Arg2);
+ if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
+ or else N /= First (Statements (Parent (N)))
+ then
+ Pragma_Misplaced;
+ end if;
- -- If the attribute is not recognized, then issue a warning (not
- -- an error), and ignore the pragma.
+ --------------------
+ -- Abstract_State --
+ --------------------
- Aname := Chars (Attribute_Designator);
+ -- pragma Abstract_State (ABSTRACT_STATE_LIST)
- if not Is_Attribute_Name (Aname) then
- Bad_Attribute (Attribute_Designator, Aname, Warn => True);
- return;
- end if;
+ -- ABSTRACT_STATE_LIST ::=
+ -- null
+ -- | STATE_NAME_WITH_PROPERTIES {, STATE_NAME_WITH_PROPERTIES}
- -- Otherwise, rewrite the pragma as an attribute definition clause
+ -- STATE_NAME_WITH_PROPERTIES ::=
+ -- STATE_NAME
+ -- | (STATE_NAME with PROPERTY_LIST)
- Rewrite (N,
- Make_Attribute_Definition_Clause (Loc,
- Name => Get_Pragma_Arg (Arg2),
- Chars => Aname,
- Expression => Get_Pragma_Arg (Arg3)));
- Analyze (N);
- end Attribute_Definition;
+ -- PROPERTY_LIST ::= PROPERTY {, PROPERTY}
+ -- PROPERTY ::= SIMPLE_PROPERTY | NAME_VALUE_PROPERTY
- ---------------
- -- AST_Entry --
- ---------------
+ -- SIMPLE_PROPERTY ::= IDENTIFIER
+ -- NAME_VALUE_PROPERTY ::= IDENTIFIER => EXPRESSION
- -- pragma AST_Entry (entry_IDENTIFIER);
+ -- STATE_NAME ::= DEFINING_IDENTIFIER
- when Pragma_AST_Entry => AST_Entry : declare
- Ent : Node_Id;
+ when Pragma_Abstract_State => Abstract_State : declare
+ Pack_Id : Entity_Id;
- begin
- GNAT_Pragma;
- Check_VMS (N);
- Check_Arg_Count (1);
- Check_No_Identifiers;
- Check_Arg_Is_Local_Name (Arg1);
- Ent := Entity (Get_Pragma_Arg (Arg1));
+ -- Flags used to verify the consistency of states
- -- Note: the implementation of the AST_Entry pragma could handle
- -- the entry family case fine, but for now we are consistent with
- -- the DEC rules, and do not allow the pragma, which of course
- -- has the effect of also forbidding the attribute.
+ Non_Null_Seen : Boolean := False;
+ Null_Seen : Boolean := False;
- if Ekind (Ent) /= E_Entry then
- Error_Pragma_Arg
- ("pragma% argument must be simple entry name", Arg1);
+ procedure Analyze_Abstract_State (State : Node_Id);
+ -- Verify the legality of a single state declaration. Create and
+ -- decorate a state abstraction entity and introduce it into the
+ -- visibility chain.
- elsif Is_AST_Entry (Ent) then
- Error_Pragma_Arg
- ("duplicate % pragma for entry", Arg1);
+ ----------------------------
+ -- Analyze_Abstract_State --
+ ----------------------------
- elsif Has_Homonym (Ent) then
- Error_Pragma_Arg
- ("pragma% argument cannot specify overloaded entry", Arg1);
+ procedure Analyze_Abstract_State (State : Node_Id) is
+ procedure Check_Duplicate_Property
+ (Prop : Node_Id;
+ Status : in out Boolean);
+ -- Flag Status denotes whether a particular property has been
+ -- seen while processing a state. This routine verifies that
+ -- Prop is not a duplicate property and sets the flag Status.
- else
- declare
- FF : constant Entity_Id := First_Formal (Ent);
+ ------------------------------
+ -- Check_Duplicate_Property --
+ ------------------------------
+ procedure Check_Duplicate_Property
+ (Prop : Node_Id;
+ Status : in out Boolean)
+ is
begin
- if Present (FF) then
- if Present (Next_Formal (FF)) then
- Error_Pragma_Arg
- ("entry for pragma% can have only one argument",
- Arg1);
-
- elsif Parameter_Mode (FF) /= E_In_Parameter then
- Error_Pragma_Arg
- ("entry parameter for pragma% must have mode IN",
- Arg1);
- end if;
+ if Status then
+ Error_Msg_N ("duplicate state property", Prop);
end if;
- end;
- Set_Is_AST_Entry (Ent);
- end if;
- end AST_Entry;
+ Status := True;
+ end Check_Duplicate_Property;
- ------------------
- -- Asynchronous --
- ------------------
+ -- Local variables
- -- pragma Asynchronous (LOCAL_NAME);
+ Errors : constant Nat := Serious_Errors_Detected;
+ Loc : constant Source_Ptr := Sloc (State);
+ Assoc : Node_Id;
+ Id : Entity_Id;
+ Is_Null : Boolean := False;
+ Level : Uint := Uint_0;
+ Name : Name_Id;
+ Prop : Node_Id;
- when Pragma_Asynchronous => Asynchronous : declare
- Nm : Entity_Id;
- C_Ent : Entity_Id;
- L : List_Id;
- S : Node_Id;
- N : Node_Id;
- Formal : Entity_Id;
+ -- Flags used to verify the consistency of properties
- procedure Process_Async_Pragma;
- -- Common processing for procedure and access-to-procedure case
+ Input_Seen : Boolean := False;
+ Integrity_Seen : Boolean := False;
+ Output_Seen : Boolean := False;
+ Volatile_Seen : Boolean := False;
- --------------------------
- -- Process_Async_Pragma --
- --------------------------
+ -- Start of processing for Analyze_Abstract_State
- procedure Process_Async_Pragma is
begin
- if No (L) then
- Set_Is_Asynchronous (Nm);
- return;
- end if;
+ -- A package with a null abstract state is not allowed to
+ -- declare additional states.
- -- The formals should be of mode IN (RM E.4.1(6))
+ if Null_Seen then
+ Error_Msg_NE
+ ("package & has null abstract state", State, Pack_Id);
- S := First (L);
- while Present (S) loop
- Formal := Defining_Identifier (S);
+ -- Null states appear as internally generated entities
- if Nkind (Formal) = N_Defining_Identifier
- and then Ekind (Formal) /= E_In_Parameter
- then
- Error_Pragma_Arg
- ("pragma% procedure can only have IN parameter",
- Arg1);
- end if;
+ elsif Nkind (State) = N_Null then
+ Name := New_Internal_Name ('S');
+ Is_Null := True;
+ Null_Seen := True;
- Next (S);
- end loop;
+ -- Catch a case where a null state appears in a list of
+ -- non-null states.
- Set_Is_Asynchronous (Nm);
- end Process_Async_Pragma;
+ if Non_Null_Seen then
+ Error_Msg_NE
+ ("package & has non-null abstract state",
+ State, Pack_Id);
+ end if;
- -- Start of processing for pragma Asynchronous
+ -- Simple state declaration
- begin
- Check_Ada_83_Warning;
- Check_No_Identifiers;
- Check_Arg_Count (1);
- Check_Arg_Is_Local_Name (Arg1);
+ elsif Nkind (State) = N_Identifier then
+ Name := Chars (State);
+ Non_Null_Seen := True;
- if Debug_Flag_U then
- return;
- end if;
+ -- State declaration with various properties. This construct
+ -- appears as an extension aggregate in the tree.
- C_Ent := Cunit_Entity (Current_Sem_Unit);
- Analyze (Get_Pragma_Arg (Arg1));
- Nm := Entity (Get_Pragma_Arg (Arg1));
+ elsif Nkind (State) = N_Extension_Aggregate then
+ if Nkind (Ancestor_Part (State)) = N_Identifier then
+ Name := Chars (Ancestor_Part (State));
+ Non_Null_Seen := True;
+ else
+ Error_Msg_N
+ ("state name must be an identifier",
+ Ancestor_Part (State));
+ end if;
- if not Is_Remote_Call_Interface (C_Ent)
- and then not Is_Remote_Types (C_Ent)
- then
- -- This pragma should only appear in an RCI or Remote Types
- -- unit (RM E.4.1(4)).
+ -- Process properties Input, Output and Volatile. Ensure
+ -- that none of them appear more than once.
- Error_Pragma
- ("pragma% not in Remote_Call_Interface or Remote_Types unit");
- end if;
+ Prop := First (Expressions (State));
+ while Present (Prop) loop
+ if Nkind (Prop) = N_Identifier then
+ if Chars (Prop) = Name_Input then
+ Check_Duplicate_Property (Prop, Input_Seen);
+ elsif Chars (Prop) = Name_Output then
+ Check_Duplicate_Property (Prop, Output_Seen);
+ elsif Chars (Prop) = Name_Volatile then
+ Check_Duplicate_Property (Prop, Volatile_Seen);
+ else
+ Error_Msg_N ("invalid state property", Prop);
+ end if;
+ else
+ Error_Msg_N ("invalid state property", Prop);
+ end if;
- if Ekind (Nm) = E_Procedure
- and then Nkind (Parent (Nm)) = N_Procedure_Specification
- then
- if not Is_Remote_Call_Interface (Nm) then
- Error_Pragma_Arg
- ("pragma% cannot be applied on non-remote procedure",
- Arg1);
- end if;
+ Next (Prop);
+ end loop;
- L := Parameter_Specifications (Parent (Nm));
- Process_Async_Pragma;
- return;
+ -- Volatile requires exactly one Input or Output
- elsif Ekind (Nm) = E_Function then
- Error_Pragma_Arg
- ("pragma% cannot be applied to function", Arg1);
+ if Volatile_Seen
+ and then
+ ((Input_Seen and then Output_Seen) -- both
+ or else
+ (not Input_Seen and then not Output_Seen)) -- none
+ then
+ Error_Msg_N
+ ("property Volatile requires exactly one Input or "
+ & "Output", State);
+ end if;
- elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
- if Is_Record_Type (Nm) then
+ -- Either Input or Output require Volatile
- -- A record type that is the Equivalent_Type for a remote
- -- access-to-subprogram type.
+ if (Input_Seen or Output_Seen)
+ and then not Volatile_Seen
+ then
+ Error_Msg_N
+ ("properties Input and Output require Volatile", State);
+ end if;
- N := Declaration_Node (Corresponding_Remote_Type (Nm));
+ -- State property Integrity appears as a component
+ -- association.
- else
- -- A non-expanded RAS type (distribution is not enabled)
+ Assoc := First (Component_Associations (State));
+ while Present (Assoc) loop
+ Prop := First (Choices (Assoc));
+ while Present (Prop) loop
+ if Nkind (Prop) = N_Identifier
+ and then Chars (Prop) = Name_Integrity
+ then
+ Check_Duplicate_Property (Prop, Integrity_Seen);
+ else
+ Error_Msg_N ("invalid state property", Prop);
+ end if;
- N := Declaration_Node (Nm);
- end if;
+ Next (Prop);
+ end loop;
- if Nkind (N) = N_Full_Type_Declaration
- and then Nkind (Type_Definition (N)) =
- N_Access_Procedure_Definition
- then
- L := Parameter_Specifications (Type_Definition (N));
- Process_Async_Pragma;
+ if Nkind (Expression (Assoc)) = N_Integer_Literal then
+ Level := Intval (Expression (Assoc));
+ else
+ Error_Msg_N
+ ("integrity level must be an integer literal",
+ Expression (Assoc));
+ end if;
- if Is_Asynchronous (Nm)
- and then Expander_Active
- and then Get_PCS_Name /= Name_No_DSA
- then
- RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
- end if;
+ Next (Assoc);
+ end loop;
+
+ -- Any other attempt to declare a state is erroneous
else
- Error_Pragma_Arg
- ("pragma% cannot reference access-to-function type",
- Arg1);
+ Error_Msg_N ("malformed abstract state declaration", State);
end if;
- -- Only other possibility is Access-to-class-wide type
+ -- Do not generate a state abstraction entity if it was not
+ -- properly declared.
- elsif Is_Access_Type (Nm)
- and then Is_Class_Wide_Type (Designated_Type (Nm))
- then
- Check_First_Subtype (Arg1);
- Set_Is_Asynchronous (Nm);
- if Expander_Active then
- RACW_Type_Is_Asynchronous (Nm);
+ if Serious_Errors_Detected > Errors then
+ return;
end if;
- else
- Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
- end if;
- end Asynchronous;
+ -- The generated state abstraction reuses the same characters
+ -- from the original state declaration. Decorate the entity.
- ------------
- -- Atomic --
- ------------
+ Id := Make_Defining_Identifier (Loc, New_External_Name (Name));
+ Set_Comes_From_Source (Id, not Is_Null);
+ Set_Parent (Id, State);
+ Set_Ekind (Id, E_Abstract_State);
+ Set_Etype (Id, Standard_Void_Type);
+ Set_Integrity_Level (Id, Level);
+ Set_Refined_State (Id, Empty);
- -- pragma Atomic (LOCAL_NAME);
+ -- Every non-null state must be nameable and resolvable the
+ -- same way a constant is.
- when Pragma_Atomic =>
- Process_Atomic_Shared_Volatile;
+ if not Is_Null then
+ Push_Scope (Pack_Id);
+ Enter_Name (Id);
+ Pop_Scope;
+ end if;
- -----------------------
- -- Atomic_Components --
- -----------------------
+ -- Associate the state with its related package
- -- pragma Atomic_Components (array_LOCAL_NAME);
+ if No (Abstract_States (Pack_Id)) then
+ Set_Abstract_States (Pack_Id, New_Elmt_List);
+ end if;
- -- This processing is shared by Volatile_Components
+ Append_Elmt (Id, Abstract_States (Pack_Id));
+ end Analyze_Abstract_State;
- when Pragma_Atomic_Components |
- Pragma_Volatile_Components =>
+ -- Local variables
- Atomic_Components : declare
- E_Id : Node_Id;
- E : Entity_Id;
- D : Node_Id;
- K : Node_Kind;
+ Par : Node_Id;
+ State : Node_Id;
+
+ -- Start of processing for Abstract_State
begin
- Check_Ada_83_Warning;
- Check_No_Identifiers;
+ GNAT_Pragma;
+ S14_Pragma;
Check_Arg_Count (1);
- Check_Arg_Is_Local_Name (Arg1);
- E_Id := Get_Pragma_Arg (Arg1);
- if Etype (E_Id) = Any_Type then
- return;
- end if;
+ -- Ensure the proper placement of the pragma. Abstract states must
+ -- be associated with a package declaration.
- E := Entity (E_Id);
+ if From_Aspect_Specification (N) then
+ Par := Parent (Corresponding_Aspect (N));
+ else
+ Par := Parent (Parent (N));
+ end if;
- Check_Duplicate_Pragma (E);
+ if Nkind (Par) = N_Compilation_Unit then
+ Par := Unit (Par);
+ end if;
- if Rep_Item_Too_Early (E, N)
- or else
- Rep_Item_Too_Late (E, N)
- then
+ if Nkind (Par) /= N_Package_Declaration then
+ Pragma_Misplaced;
return;
end if;
- D := Declaration_Node (E);
- K := Nkind (D);
+ Pack_Id := Defining_Entity (Par);
+ State := Expression (Arg1);
- if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
- or else
- ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
- and then Nkind (D) = N_Object_Declaration
- and then Nkind (Object_Definition (D)) =
- N_Constrained_Array_Definition)
- then
- -- The flag is set on the object, or on the base type
+ -- Multiple abstract states appear as an aggregate
- if Nkind (D) /= N_Object_Declaration then
- E := Base_Type (E);
- end if;
+ if Nkind (State) = N_Aggregate then
+ State := First (Expressions (State));
+ while Present (State) loop
+ Analyze_Abstract_State (State);
- Set_Has_Volatile_Components (E);
+ Next (State);
+ end loop;
- if Prag_Id = Pragma_Atomic_Components then
- Set_Has_Atomic_Components (E);
- end if;
+ -- Various forms of a single abstract state. Note that these may
+ -- include malformed state declarations.
else
- Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
+ Analyze_Abstract_State (State);
end if;
- end Atomic_Components;
+ end Abstract_State;
- --------------------
- -- Attach_Handler --
- --------------------
+ ------------
+ -- Ada_83 --
+ ------------
- -- pragma Attach_Handler (handler_NAME, EXPRESSION);
+ -- pragma Ada_83;
- when Pragma_Attach_Handler =>
- Check_Ada_83_Warning;
- Check_No_Identifiers;
- Check_Arg_Count (2);
+ -- Note: this pragma also has some specific processing in Par.Prag
+ -- because we want to set the Ada version mode during parsing.
- if No_Run_Time_Mode then
- Error_Msg_CRT ("Attach_Handler pragma", N);
- else
- Check_Interrupt_Or_Attach_Handler;
+ when Pragma_Ada_83 =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
- -- The expression that designates the attribute may depend on a
- -- discriminant, and is therefore a per-object expression, to
- -- be expanded in the init proc. If expansion is enabled, then
- -- perform semantic checks on a copy only.
+ -- We really should check unconditionally for proper configuration
+ -- pragma placement, since we really don't want mixed Ada modes
+ -- within a single unit, and the GNAT reference manual has always
+ -- said this was a configuration pragma, but we did not check and
+ -- are hesitant to add the check now.
- if Expander_Active then
- declare
- Temp : constant Node_Id :=
- New_Copy_Tree (Get_Pragma_Arg (Arg2));
- begin
- Set_Parent (Temp, N);
- Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
- end;
+ -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
+ -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
+ -- or Ada 2012 mode.
- else
- Analyze (Get_Pragma_Arg (Arg2));
- Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID));
- end if;
+ if Ada_Version >= Ada_2005 then
+ Check_Valid_Configuration_Pragma;
+ end if;
- Process_Interrupt_Or_Attach_Handler;
+ -- Now set Ada 83 mode
+
+ Ada_Version := Ada_83;
+ Ada_Version_Explicit := Ada_Version;
+
+ ------------
+ -- Ada_95 --
+ ------------
+
+ -- pragma Ada_95;
+
+ -- Note: this pragma also has some specific processing in Par.Prag
+ -- because we want to set the Ada 83 version mode during parsing.
+
+ when Pragma_Ada_95 =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+
+ -- We really should check unconditionally for proper configuration
+ -- pragma placement, since we really don't want mixed Ada modes
+ -- within a single unit, and the GNAT reference manual has always
+ -- said this was a configuration pragma, but we did not check and
+ -- are hesitant to add the check now.
+
+ -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
+ -- or Ada 95, so we must check if we are in Ada 2005 mode.
+
+ if Ada_Version >= Ada_2005 then
+ Check_Valid_Configuration_Pragma;
end if;
- --------------------
- -- C_Pass_By_Copy --
- --------------------
+ -- Now set Ada 95 mode
- -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
+ Ada_Version := Ada_95;
+ Ada_Version_Explicit := Ada_Version;
- when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
- Arg : Node_Id;
- Val : Uint;
+ ---------------------
+ -- Ada_05/Ada_2005 --
+ ---------------------
+
+ -- pragma Ada_05;
+ -- pragma Ada_05 (LOCAL_NAME);
+
+ -- pragma Ada_2005;
+ -- pragma Ada_2005 (LOCAL_NAME):
+
+ -- Note: these pragmas also have some specific processing in Par.Prag
+ -- because we want to set the Ada 2005 version mode during parsing.
+
+ when Pragma_Ada_05 | Pragma_Ada_2005 => declare
+ E_Id : Node_Id;
begin
GNAT_Pragma;
- Check_Valid_Configuration_Pragma;
- Check_Arg_Count (1);
- Check_Optional_Identifier (Arg1, "max_size");
- Arg := Get_Pragma_Arg (Arg1);
- Check_Arg_Is_Static_Expression (Arg, Any_Integer);
+ if Arg_Count = 1 then
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
- Val := Expr_Value (Arg);
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
- if Val <= 0 then
- Error_Pragma_Arg
- ("maximum size for pragma% must be positive", Arg1);
+ Set_Is_Ada_2005_Only (Entity (E_Id));
+ Record_Rep_Item (Entity (E_Id), N);
- elsif UI_Is_In_Int_Range (Val) then
- Default_C_Record_Mechanism := UI_To_Int (Val);
+ else
+ Check_Arg_Count (0);
- -- If a giant value is given, Int'Last will do well enough.
- -- If sometime someone complains that a record larger than
- -- two gigabytes is not copied, we will worry about it then!
+ -- For Ada_2005 we unconditionally enforce the documented
+ -- configuration pragma placement, since we do not want to
+ -- tolerate mixed modes in a unit involving Ada 2005. That
+ -- would cause real difficulties for those cases where there
+ -- are incompatibilities between Ada 95 and Ada 2005.
- else
- Default_C_Record_Mechanism := Mechanism_Type'Last;
- end if;
- end C_Pass_By_Copy;
+ Check_Valid_Configuration_Pragma;
- -----------
- -- Check --
- -----------
+ -- Now set appropriate Ada mode
+
+ Ada_Version := Ada_2005;
+ Ada_Version_Explicit := Ada_2005;
+ end if;
+ end;
- -- pragma Check ([Name =>] CHECK_KIND,
- -- [Check =>] Boolean_EXPRESSION
- -- [,[Message =>] String_EXPRESSION]);
+ ---------------------
+ -- Ada_12/Ada_2012 --
+ ---------------------
- -- CHECK_KIND ::= IDENTIFIER |
- -- Pre'Class |
- -- Post'Class |
- -- Invariant'Class |
- -- Type_Invariant'Class
+ -- pragma Ada_12;
+ -- pragma Ada_12 (LOCAL_NAME);
- -- The identifiers Assertions and Statement_Assertions are not
- -- allowed, since they have special meaning for Check_Policy.
+ -- pragma Ada_2012;
+ -- pragma Ada_2012 (LOCAL_NAME):
- when Pragma_Check => Check : declare
- Expr : Node_Id;
- Eloc : Source_Ptr;
- Cname : Name_Id;
- Str : Node_Id;
+ -- Note: these pragmas also have some specific processing in Par.Prag
+ -- because we want to set the Ada 2012 version mode during parsing.
- Check_On : Boolean;
- -- Set True if category of assertions referenced by Name enabled
+ when Pragma_Ada_12 | Pragma_Ada_2012 => declare
+ E_Id : Node_Id;
begin
GNAT_Pragma;
- Check_At_Least_N_Arguments (2);
- Check_At_Most_N_Arguments (3);
- Check_Optional_Identifier (Arg1, Name_Name);
- Check_Optional_Identifier (Arg2, Name_Check);
- if Arg_Count = 3 then
- Check_Optional_Identifier (Arg3, Name_Message);
- Str := Get_Pragma_Arg (Arg3);
- end if;
-
- Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
- Check_Arg_Is_Identifier (Arg1);
- Cname := Chars (Get_Pragma_Arg (Arg1));
+ if Arg_Count = 1 then
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
- -- Check forbidden name Assertions or Statement_Assertions
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
- case Cname is
- when Name_Assertions =>
- Error_Pragma_Arg
- ("""Assertions"" is not allowed as a check kind "
- & "for pragma%", Arg1);
+ Set_Is_Ada_2012_Only (Entity (E_Id));
+ Record_Rep_Item (Entity (E_Id), N);
- when Name_Statement_Assertions =>
- Error_Pragma_Arg
- ("""Statement_Assertions"" is not allowed as a check kind "
- & "for pragma%", Arg1);
+ else
+ Check_Arg_Count (0);
- when others =>
- null;
- end case;
+ -- For Ada_2012 we unconditionally enforce the documented
+ -- configuration pragma placement, since we do not want to
+ -- tolerate mixed modes in a unit involving Ada 2012. That
+ -- would cause real difficulties for those cases where there
+ -- are incompatibilities between Ada 95 and Ada 2012. We could
+ -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
- -- Set Check_On to indicate check status
+ Check_Valid_Configuration_Pragma;
- -- If this comes from an aspect, we have already taken care of
- -- the policy active when the aspect was analyzed, and Is_Ignored
- -- is set appropriately already.
+ -- Now set appropriate Ada mode
- if From_Aspect_Specification (N) then
- Check_On := not Is_Ignored (N);
+ Ada_Version := Ada_2012;
+ Ada_Version_Explicit := Ada_2012;
+ end if;
+ end;
- -- Otherwise check the status right now
+ ----------------------
+ -- All_Calls_Remote --
+ ----------------------
- else
- case Check_Kind (Cname) is
- when Name_Ignore =>
- Check_On := False;
+ -- pragma All_Calls_Remote [(library_package_NAME)];
- when Name_Check =>
- Check_On := True;
+ when Pragma_All_Calls_Remote => All_Calls_Remote : declare
+ Lib_Entity : Entity_Id;
- -- For disable, rewrite pragma as null statement and skip
- -- rest of the analysis of the pragma.
+ begin
+ Check_Ada_83_Warning;
+ Check_Valid_Library_Unit_Pragma;
- when Name_Disable =>
- Rewrite (N, Make_Null_Statement (Loc));
- Analyze (N);
- raise Pragma_Exit;
+ if Nkind (N) = N_Null_Statement then
+ return;
+ end if;
- -- No other possibilities
+ Lib_Entity := Find_Lib_Unit_Name;
- when others =>
- raise Program_Error;
- end case;
- end if;
+ -- This pragma should only apply to a RCI unit (RM E.2.3(23))
- -- If check kind was not Disable, then continue pragma analysis
+ if Present (Lib_Entity)
+ and then not Debug_Flag_U
+ then
+ if not Is_Remote_Call_Interface (Lib_Entity) then
+ Error_Pragma ("pragma% only apply to rci unit");
- Expr := Get_Pragma_Arg (Arg2);
+ -- Set flag for entity of the library unit
- -- Deal with SCO generation
+ else
+ Set_Has_All_Calls_Remote (Lib_Entity);
+ end if;
- case Cname is
- when Name_Predicate |
- Name_Invariant =>
+ end if;
+ end All_Calls_Remote;
- -- Nothing to do: since checks occur in client units,
- -- the SCO for the aspect in the declaration unit is
- -- conservatively always enabled.
+ --------------
+ -- Annotate --
+ --------------
- null;
+ -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
+ -- ARG ::= NAME | EXPRESSION
- when others =>
+ -- The first two arguments are by convention intended to refer to an
+ -- external tool and a tool-specific function. These arguments are
+ -- not analyzed.
- if Check_On and then not Split_PPC (N) then
+ when Pragma_Annotate => Annotate : declare
+ Arg : Node_Id;
+ Exp : Node_Id;
- -- Mark pragma/aspect SCO as enabled
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (1);
+ Check_Arg_Is_Identifier (Arg1);
+ Check_No_Identifiers;
+ Store_Note (N);
- Set_SCO_Pragma_Enabled (Loc);
- end if;
- end case;
+ -- Second parameter is optional, it is never analyzed
- -- Deal with analyzing the string argument.
+ if No (Arg2) then
+ null;
- if Arg_Count = 3 then
+ -- Here if we have a second parameter
- -- If checks are not on we don't want any expansion (since
- -- such expansion would not get properly deleted) but
- -- we do want to analyze (to get proper references).
- -- The Preanalyze_And_Resolve routine does just what we want
+ else
+ -- Second parameter must be identifier
- if not Check_On then
- Preanalyze_And_Resolve (Str, Standard_String);
+ Check_Arg_Is_Identifier (Arg2);
- -- Otherwise we need a proper analysis and expansion
+ -- Process remaining parameters if any
- else
- Analyze_And_Resolve (Str, Standard_String);
- end if;
- end if;
+ Arg := Next (Arg2);
+ while Present (Arg) loop
+ Exp := Get_Pragma_Arg (Arg);
+ Analyze (Exp);
- -- Now you might think we could just do the same with the Boolean
- -- expression if checks are off (and expansion is on) and then
- -- rewrite the check as a null statement. This would work but we
- -- would lose the useful warnings about an assertion being bound
- -- to fail even if assertions are turned off.
+ if Is_Entity_Name (Exp) then
+ null;
- -- So instead we wrap the boolean expression in an if statement
- -- that looks like:
+ -- For string literals, we assume Standard_String as the
+ -- type, unless the string contains wide or wide_wide
+ -- characters.
- -- if False and then condition then
- -- null;
- -- end if;
+ elsif Nkind (Exp) = N_String_Literal then
+ if Has_Wide_Wide_Character (Exp) then
+ Resolve (Exp, Standard_Wide_Wide_String);
+ elsif Has_Wide_Character (Exp) then
+ Resolve (Exp, Standard_Wide_String);
+ else
+ Resolve (Exp, Standard_String);
+ end if;
- -- The reason we do this rewriting during semantic analysis
- -- rather than as part of normal expansion is that we cannot
- -- analyze and expand the code for the boolean expression
- -- directly, or it may cause insertion of actions that would
- -- escape the attempt to suppress the check code.
+ elsif Is_Overloaded (Exp) then
+ Error_Pragma_Arg
+ ("ambiguous argument for pragma%", Exp);
- -- Note that the Sloc for the if statement corresponds to the
- -- argument condition, not the pragma itself. The reason for
- -- this is that we may generate a warning if the condition is
- -- False at compile time, and we do not want to delete this
- -- warning when we delete the if statement.
+ else
+ Resolve (Exp);
+ end if;
- if Expander_Active and not Check_On then
- Eloc := Sloc (Expr);
+ Next (Arg);
+ end loop;
+ end if;
+ end Annotate;
- Rewrite (N,
- Make_If_Statement (Eloc,
- Condition =>
- Make_And_Then (Eloc,
- Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
- Right_Opnd => Expr),
- Then_Statements => New_List (
- Make_Null_Statement (Eloc))));
+ ---------------------------
+ -- Assert/Assert_And_Cut --
+ ---------------------------
- In_Assertion_Expr := In_Assertion_Expr + 1;
- Analyze (N);
- In_Assertion_Expr := In_Assertion_Expr - 1;
+ -- pragma Assert
+ -- ( [Check => ] Boolean_EXPRESSION
+ -- [, [Message =>] Static_String_EXPRESSION]);
- -- Check is active or expansion not active. In these cases we can
- -- just go ahead and analyze the boolean with no worries.
+ -- pragma Assert_And_Cut
+ -- ( [Check => ] Boolean_EXPRESSION
+ -- [, [Message =>] Static_String_EXPRESSION]);
- else
- In_Assertion_Expr := In_Assertion_Expr + 1;
- Analyze_And_Resolve (Expr, Any_Boolean);
- In_Assertion_Expr := In_Assertion_Expr - 1;
+ when Pragma_Assert | Pragma_Assert_And_Cut => Assert : declare
+ Expr : Node_Id;
+ Newa : List_Id;
+
+ begin
+ if Prag_Id = Pragma_Assert then
+ Ada_2005_Pragma;
+ else -- Pragma_Assert_And_Cut
+ GNAT_Pragma;
+ S14_Pragma;
end if;
- end Check;
- --------------------------
- -- Check_Float_Overflow --
- --------------------------
+ Check_At_Least_N_Arguments (1);
+ Check_At_Most_N_Arguments (2);
+ Check_Arg_Order ((Name_Check, Name_Message));
+ Check_Optional_Identifier (Arg1, Name_Check);
- -- pragma Check_Float_Overflow;
+ -- We treat pragma Assert[_And_Cut] as equivalent to:
- when Pragma_Check_Float_Overflow =>
- GNAT_Pragma;
- Check_Valid_Configuration_Pragma;
- Check_Arg_Count (0);
- Check_Float_Overflow := True;
+ -- pragma Check (Assert[_And_Cut], condition [, msg]);
- ----------------
- -- Check_Name --
- ----------------
+ -- So rewrite pragma in this manner, transfer the message
+ -- argument if present, and analyze the result
- -- pragma Check_Name (check_IDENTIFIER);
+ -- Pragma Assert_And_Cut is treated exactly like pragma Assert by
+ -- the frontend. Formal verification tools may use it to "cut" the
+ -- paths through the code, to make verification tractable. When
+ -- dealing with a semantically analyzed tree, the information that
+ -- a Check node N corresponds to a source Assert_And_Cut pragma
+ -- can be retrieved from the pragma kind of Original_Node(N).
- when Pragma_Check_Name =>
- Check_No_Identifiers;
- GNAT_Pragma;
- Check_Valid_Configuration_Pragma;
- Check_Arg_Count (1);
- Check_Arg_Is_Identifier (Arg1);
+ Expr := Get_Pragma_Arg (Arg1);
+ Newa := New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Pname)),
+ Make_Pragma_Argument_Association (Sloc (Expr),
+ Expression => Expr));
- declare
- Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
+ if Arg_Count > 1 then
+ Check_Optional_Identifier (Arg2, Name_Message);
+ Append_To (Newa, New_Copy_Tree (Arg2));
+ end if;
- begin
- for J in Check_Names.First .. Check_Names.Last loop
- if Check_Names.Table (J) = Nam then
- return;
- end if;
- end loop;
+ Rewrite (N,
+ Make_Pragma (Loc,
+ Chars => Name_Check,
+ Pragma_Argument_Associations => Newa));
+ Analyze (N);
+ end Assert;
- Check_Names.Append (Nam);
- end;
+ ----------------------
+ -- Assertion_Policy --
+ ----------------------
- ------------------
- -- Check_Policy --
- ------------------
+ -- pragma Assertion_Policy (POLICY_IDENTIFIER);
- -- This is the old style syntax, which is still allowed in all modes:
+ -- The following form is Ada 2012 only, but we allow it in all modes
- -- pragma Check_Policy ([Name =>] CHECK_KIND
- -- [Policy =>] POLICY_IDENTIFIER);
+ -- Pragma Assertion_Policy (
+ -- ASSERTION_KIND => POLICY_IDENTIFIER
+ -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
- -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
+ -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
- -- CHECK_KIND ::= IDENTIFIER |
- -- Pre'Class |
- -- Post'Class |
- -- Type_Invariant'Class |
- -- Invariant'Class
+ -- RM_ASSERTION_KIND ::= Assert |
+ -- Static_Predicate |
+ -- Dynamic_Predicate |
+ -- Pre |
+ -- Pre'Class |
+ -- Post |
+ -- Post'Class |
+ -- Type_Invariant |
+ -- Type_Invariant'Class
- -- This is the new style syntax, compatible with Assertion_Policy
- -- and also allowed in all modes.
+ -- ID_ASSERTION_KIND ::= Assert_And_Cut |
+ -- Assume |
+ -- Contract_Cases |
+ -- Debug |
+ -- Loop_Invariant |
+ -- Loop_Variant |
+ -- Postcondition |
+ -- Precondition |
+ -- Predicate |
+ -- Statement_Assertions
+ --
+ -- Note: The RM_ASSERTION_KIND list is language-defined, and the
+ -- ID_ASSERTION_KIND list contains implementation-defined additions
+ -- recognized by GNAT. The effect is to control the behavior of
+ -- identically named aspects and pragmas, depending on the specified
+ -- policy identifier:
- -- Pragma Check_Policy (
- -- CHECK_KIND => POLICY_IDENTIFIER
- -- {, CHECK_KIND => POLICY_IDENTIFIER});
+ -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
- -- Note: the identifiers Name and Policy are not allowed as
- -- Check_Kind values. This avoids ambiguities between the old and
- -- new form syntax.
+ -- Note: Check and Ignore are language-defined. Disable is a GNAT
+ -- implementation defined addition that results in totally ignoring
+ -- the corresponding assertion. If Disable is specified, then the
+ -- argument of the assertion is not even analyzed. This is useful
+ -- when the aspect/pragma argument references entities in a with'ed
+ -- package that is replaced by a dummy package in the final build.
- when Pragma_Check_Policy => Check_Policy : declare
- Kind : Node_Id;
+ -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
+ -- and Type_Invariant'Class were recognized by the parser and
+ -- transformed into references to the special internal identifiers
+ -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
+ -- processing is required here.
+
+ when Pragma_Assertion_Policy => Assertion_Policy : declare
+ LocP : Source_Ptr;
+ Policy : Node_Id;
+ Arg : Node_Id;
+ Kind : Name_Id;
begin
- GNAT_Pragma;
- Check_At_Least_N_Arguments (1);
+ Ada_2005_Pragma;
- -- A Check_Policy pragma can appear either as a configuration
- -- pragma, or in a declarative part or a package spec (see RM
- -- 11.5(5) for rules for Suppress/Unsuppress which are also
- -- followed for Check_Policy).
+ -- This can always appear as a configuration pragma
- if not Is_Configuration_Pragma then
+ if Is_Configuration_Pragma then
+ null;
+
+ -- It can also appear in a declarative part or package spec in Ada
+ -- 2012 mode. We allow this in other modes, but in that case we
+ -- consider that we have an Ada 2012 pragma on our hands.
+
+ else
Check_Is_In_Decl_Part_Or_Package_Spec;
+ Ada_2012_Pragma;
end if;
- -- Figure out if we have the old or new syntax. We have the
- -- old syntax if the first argument has no identifier, or the
- -- identifier is Name.
+ -- One argument case with no identifier (first form above)
- if Nkind (Arg1) /= N_Pragma_Argument_Association
- or else Nam_In (Chars (Arg1), No_Name, Name_Name)
+ if Arg_Count = 1
+ and then (Nkind (Arg1) /= N_Pragma_Argument_Association
+ or else Chars (Arg1) = No_Name)
then
- -- Old syntax
-
- Check_Arg_Count (2);
- Check_Optional_Identifier (Arg1, Name_Name);
- Kind := Get_Pragma_Arg (Arg1);
- Rewrite_Assertion_Kind (Kind);
- Check_Arg_Is_Identifier (Arg1);
-
- -- Check forbidden check kind
-
- if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
- Error_Msg_Name_2 := Chars (Kind);
- Error_Pragma_Arg
- ("pragma% does not allow% as check name", Arg1);
- end if;
-
- -- Check policy
-
- Check_Optional_Identifier (Arg2, Name_Policy);
Check_Arg_Is_One_Of
- (Arg2,
- Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
-
- -- And chain pragma on the Check_Policy_List for search
-
- Set_Next_Pragma (N, Opt.Check_Policy_List);
- Opt.Check_Policy_List := N;
+ (Arg1, Name_Check, Name_Disable, Name_Ignore);
- -- For the new syntax, what we do is to convert each argument to
- -- an old syntax equivalent. We do that because we want to chain
- -- old style Check_Policy pragmas for the search (we don't want
- -- to have to deal with multiple arguments in the search).
+ -- Treat one argument Assertion_Policy as equivalent to:
- else
- declare
- Arg : Node_Id;
- Argx : Node_Id;
- LocP : Source_Ptr;
+ -- pragma Check_Policy (Assertion, policy)
- begin
- Arg := Arg1;
- while Present (Arg) loop
- LocP := Sloc (Arg);
- Argx := Get_Pragma_Arg (Arg);
+ -- So rewrite pragma in that manner and link on to the chain
+ -- of Check_Policy pragmas, marking the pragma as analyzed.
- -- Kind must be specified
+ Policy := Get_Pragma_Arg (Arg1);
- if Nkind (Arg) /= N_Pragma_Argument_Association
- or else Chars (Arg) = No_Name
- then
- Error_Pragma_Arg
- ("missing assertion kind for pragma%", Arg);
- end if;
+ Rewrite (N,
+ Make_Pragma (Loc,
+ Chars => Name_Check_Policy,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Name_Assertion)),
- -- Construct equivalent old form syntax Check_Policy
- -- pragma and insert it to get remaining checks.
+ Make_Pragma_Argument_Association (Loc,
+ Expression =>
+ Make_Identifier (Sloc (Policy), Chars (Policy))))));
+ Analyze (N);
- Insert_Action (N,
- Make_Pragma (LocP,
- Chars => Name_Check_Policy,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (LocP,
- Expression =>
- Make_Identifier (LocP, Chars (Arg))),
- Make_Pragma_Argument_Association (Sloc (Argx),
- Expression => Argx))));
+ -- Here if we have two or more arguments
- Arg := Next (Arg);
- end loop;
+ else
+ Check_At_Least_N_Arguments (1);
+ Ada_2012_Pragma;
- -- Rewrite original Check_Policy pragma to null, since we
- -- have converted it into a series of old syntax pragmas.
+ -- Loop through arguments
- Rewrite (N, Make_Null_Statement (Loc));
- Analyze (N);
- end;
- end if;
- end Check_Policy;
+ Arg := Arg1;
+ while Present (Arg) loop
+ LocP := Sloc (Arg);
- ---------------------
- -- CIL_Constructor --
- ---------------------
+ -- Kind must be specified
- -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
+ if Nkind (Arg) /= N_Pragma_Argument_Association
+ or else Chars (Arg) = No_Name
+ then
+ Error_Pragma_Arg
+ ("missing assertion kind for pragma%", Arg);
+ end if;
- -- Processing for this pragma is shared with Java_Constructor
+ -- Check Kind and Policy have allowed forms
- -------------
- -- Comment --
- -------------
+ Kind := Chars (Arg);
- -- pragma Comment (static_string_EXPRESSION)
+ if not Is_Valid_Assertion_Kind (Kind) then
+ Error_Pragma_Arg
+ ("invalid assertion kind for pragma%", Arg);
+ end if;
- -- Processing for pragma Comment shares the circuitry for pragma
- -- Ident. The only differences are that Ident enforces a limit of 31
- -- characters on its argument, and also enforces limitations on
- -- placement for DEC compatibility. Pragma Comment shares neither of
- -- these restrictions.
+ Check_Arg_Is_One_Of
+ (Arg, Name_Check, Name_Disable, Name_Ignore);
- -------------------
- -- Common_Object --
- -------------------
+ -- We rewrite the Assertion_Policy pragma as a series of
+ -- Check_Policy pragmas:
- -- pragma Common_Object (
- -- [Internal =>] LOCAL_NAME
- -- [, [External =>] EXTERNAL_SYMBOL]
- -- [, [Size =>] EXTERNAL_SYMBOL]);
+ -- Check_Policy (Kind, Policy);
- -- Processing for this pragma is shared with Psect_Object
+ Insert_Action (N,
+ Make_Pragma (LocP,
+ Chars => Name_Check_Policy,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (LocP,
+ Expression => Make_Identifier (LocP, Kind)),
+ Make_Pragma_Argument_Association (LocP,
+ Expression => Get_Pragma_Arg (Arg)))));
- ------------------------
- -- Compile_Time_Error --
- ------------------------
+ Arg := Next (Arg);
+ end loop;
- -- pragma Compile_Time_Error
- -- (boolean_EXPRESSION, static_string_EXPRESSION);
+ -- Rewrite the Assertion_Policy pragma as null since we have
+ -- now inserted all the equivalent Check pragmas.
- when Pragma_Compile_Time_Error =>
- GNAT_Pragma;
- Process_Compile_Time_Warning_Or_Error;
+ Rewrite (N, Make_Null_Statement (Loc));
+ Analyze (N);
+ end if;
+ end Assertion_Policy;
- --------------------------
- -- Compile_Time_Warning --
- --------------------------
+ ------------
+ -- Assume --
+ ------------
- -- pragma Compile_Time_Warning
- -- (boolean_EXPRESSION, static_string_EXPRESSION);
+ -- pragma Assume (boolean_EXPRESSION);
- when Pragma_Compile_Time_Warning =>
+ when Pragma_Assume => Assume : declare
+ begin
GNAT_Pragma;
- Process_Compile_Time_Warning_Or_Error;
+ S14_Pragma;
+ Check_Arg_Count (1);
- -------------------
- -- Compiler_Unit --
- -------------------
+ -- Pragma Assume is transformed into pragma Check in the following
+ -- manner:
- when Pragma_Compiler_Unit =>
- GNAT_Pragma;
- Check_Arg_Count (0);
- Set_Is_Compiler_Unit (Get_Source_Unit (N));
+ -- pragma Check (Assume, Expr);
- -----------------------------
- -- Complete_Representation --
- -----------------------------
+ Rewrite (N,
+ Make_Pragma (Loc,
+ Chars => Name_Check,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Name_Assume)),
- -- pragma Complete_Representation;
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Relocate_Node (Expression (Arg1))))));
+ Analyze (N);
+ end Assume;
- when Pragma_Complete_Representation =>
+ ------------------------------
+ -- Assume_No_Invalid_Values --
+ ------------------------------
+
+ -- pragma Assume_No_Invalid_Values (On | Off);
+
+ when Pragma_Assume_No_Invalid_Values =>
GNAT_Pragma;
- Check_Arg_Count (0);
+ Check_Valid_Configuration_Pragma;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
- if Nkind (Parent (N)) /= N_Record_Representation_Clause then
- Error_Pragma
- ("pragma & must appear within record representation clause");
+ if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
+ Assume_No_Invalid_Values := True;
+ else
+ Assume_No_Invalid_Values := False;
end if;
- ----------------------------
- -- Complex_Representation --
- ----------------------------
+ --------------------------
+ -- Attribute_Definition --
+ --------------------------
- -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
+ -- pragma Attribute_Definition
+ -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
+ -- [Entity =>] LOCAL_NAME,
+ -- [Expression =>] EXPRESSION | NAME);
- when Pragma_Complex_Representation => Complex_Representation : declare
- E_Id : Entity_Id;
- E : Entity_Id;
- Ent : Entity_Id;
+ when Pragma_Attribute_Definition => Attribute_Definition : declare
+ Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
+ Aname : Name_Id;
begin
GNAT_Pragma;
- Check_Arg_Count (1);
- Check_Optional_Identifier (Arg1, Name_Entity);
- Check_Arg_Is_Local_Name (Arg1);
- E_Id := Get_Pragma_Arg (Arg1);
+ Check_Arg_Count (3);
+ Check_Optional_Identifier (Arg1, "attribute");
+ Check_Optional_Identifier (Arg2, "entity");
+ Check_Optional_Identifier (Arg3, "expression");
- if Etype (E_Id) = Any_Type then
+ if Nkind (Attribute_Designator) /= N_Identifier then
+ Error_Msg_N ("attribute name expected", Attribute_Designator);
return;
end if;
- E := Entity (E_Id);
-
- if not Is_Record_Type (E) then
- Error_Pragma_Arg
- ("argument for pragma% must be record type", Arg1);
- end if;
-
- Ent := First_Entity (E);
-
- if No (Ent)
- or else No (Next_Entity (Ent))
- or else Present (Next_Entity (Next_Entity (Ent)))
- or else not Is_Floating_Point_Type (Etype (Ent))
- or else Etype (Ent) /= Etype (Next_Entity (Ent))
- then
- Error_Pragma_Arg
- ("record for pragma% must have two fields of the same "
- & "floating-point type", Arg1);
+ Check_Arg_Is_Local_Name (Arg2);
- else
- Set_Has_Complex_Representation (Base_Type (E));
+ -- If the attribute is not recognized, then issue a warning (not
+ -- an error), and ignore the pragma.
- -- We need to treat the type has having a non-standard
- -- representation, for back-end purposes, even though in
- -- general a complex will have the default representation
- -- of a record with two real components.
+ Aname := Chars (Attribute_Designator);
- Set_Has_Non_Standard_Rep (Base_Type (E));
+ if not Is_Attribute_Name (Aname) then
+ Bad_Attribute (Attribute_Designator, Aname, Warn => True);
+ return;
end if;
- end Complex_Representation;
- -------------------------
- -- Component_Alignment --
- -------------------------
+ -- Otherwise, rewrite the pragma as an attribute definition clause
- -- pragma Component_Alignment (
- -- [Form =>] ALIGNMENT_CHOICE
- -- [, [Name =>] type_LOCAL_NAME]);
- --
- -- ALIGNMENT_CHOICE ::=
- -- Component_Size
- -- | Component_Size_4
- -- | Storage_Unit
- -- | Default
+ Rewrite (N,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => Get_Pragma_Arg (Arg2),
+ Chars => Aname,
+ Expression => Get_Pragma_Arg (Arg3)));
+ Analyze (N);
+ end Attribute_Definition;
- when Pragma_Component_Alignment => Component_AlignmentP : declare
- Args : Args_List (1 .. 2);
- Names : constant Name_List (1 .. 2) := (
- Name_Form,
- Name_Name);
+ ---------------
+ -- AST_Entry --
+ ---------------
- Form : Node_Id renames Args (1);
- Name : Node_Id renames Args (2);
+ -- pragma AST_Entry (entry_IDENTIFIER);
- Atype : Component_Alignment_Kind;
- Typ : Entity_Id;
+ when Pragma_AST_Entry => AST_Entry : declare
+ Ent : Node_Id;
begin
GNAT_Pragma;
- Gather_Associations (Names, Args);
-
- if No (Form) then
- Error_Pragma ("missing Form argument for pragma%");
- end if;
+ Check_VMS (N);
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_Local_Name (Arg1);
+ Ent := Entity (Get_Pragma_Arg (Arg1));
- Check_Arg_Is_Identifier (Form);
+ -- Note: the implementation of the AST_Entry pragma could handle
+ -- the entry family case fine, but for now we are consistent with
+ -- the DEC rules, and do not allow the pragma, which of course
+ -- has the effect of also forbidding the attribute.
- -- Get proper alignment, note that Default = Component_Size on all
- -- machines we have so far, and we want to set this value rather
- -- than the default value to indicate that it has been explicitly
- -- set (and thus will not get overridden by the default component
- -- alignment for the current scope)
+ if Ekind (Ent) /= E_Entry then
+ Error_Pragma_Arg
+ ("pragma% argument must be simple entry name", Arg1);
- if Chars (Form) = Name_Component_Size then
- Atype := Calign_Component_Size;
+ elsif Is_AST_Entry (Ent) then
+ Error_Pragma_Arg
+ ("duplicate % pragma for entry", Arg1);
- elsif Chars (Form) = Name_Component_Size_4 then
- Atype := Calign_Component_Size_4;
+ elsif Has_Homonym (Ent) then
+ Error_Pragma_Arg
+ ("pragma% argument cannot specify overloaded entry", Arg1);
- elsif Chars (Form) = Name_Default then
- Atype := Calign_Component_Size;
+ else
+ declare
+ FF : constant Entity_Id := First_Formal (Ent);
- elsif Chars (Form) = Name_Storage_Unit then
- Atype := Calign_Storage_Unit;
+ begin
+ if Present (FF) then
+ if Present (Next_Formal (FF)) then
+ Error_Pragma_Arg
+ ("entry for pragma% can have only one argument",
+ Arg1);
- else
- Error_Pragma_Arg
- ("invalid Form parameter for pragma%", Form);
+ elsif Parameter_Mode (FF) /= E_In_Parameter then
+ Error_Pragma_Arg
+ ("entry parameter for pragma% must have mode IN",
+ Arg1);
+ end if;
+ end if;
+ end;
+
+ Set_Is_AST_Entry (Ent);
end if;
+ end AST_Entry;
- -- Case with no name, supplied, affects scope table entry
+ ------------------
+ -- Asynchronous --
+ ------------------
- if No (Name) then
- Scope_Stack.Table
- (Scope_Stack.Last).Component_Alignment_Default := Atype;
+ -- pragma Asynchronous (LOCAL_NAME);
- -- Case of name supplied
+ when Pragma_Asynchronous => Asynchronous : declare
+ Nm : Entity_Id;
+ C_Ent : Entity_Id;
+ L : List_Id;
+ S : Node_Id;
+ N : Node_Id;
+ Formal : Entity_Id;
- else
- Check_Arg_Is_Local_Name (Name);
- Find_Type (Name);
- Typ := Entity (Name);
+ procedure Process_Async_Pragma;
+ -- Common processing for procedure and access-to-procedure case
- if Typ = Any_Type
- or else Rep_Item_Too_Early (Typ, N)
- then
+ --------------------------
+ -- Process_Async_Pragma --
+ --------------------------
+
+ procedure Process_Async_Pragma is
+ begin
+ if No (L) then
+ Set_Is_Asynchronous (Nm);
return;
- else
- Typ := Underlying_Type (Typ);
end if;
- if not Is_Record_Type (Typ)
- and then not Is_Array_Type (Typ)
- then
- Error_Pragma_Arg
- ("Name parameter of pragma% must identify record or "
- & "array type", Name);
- end if;
+ -- The formals should be of mode IN (RM E.4.1(6))
- -- An explicit Component_Alignment pragma overrides an
- -- implicit pragma Pack, but not an explicit one.
+ S := First (L);
+ while Present (S) loop
+ Formal := Defining_Identifier (S);
- if not Has_Pragma_Pack (Base_Type (Typ)) then
- Set_Is_Packed (Base_Type (Typ), False);
- Set_Component_Alignment (Base_Type (Typ), Atype);
- end if;
- end if;
- end Component_AlignmentP;
+ if Nkind (Formal) = N_Defining_Identifier
+ and then Ekind (Formal) /= E_In_Parameter
+ then
+ Error_Pragma_Arg
+ ("pragma% procedure can only have IN parameter",
+ Arg1);
+ end if;
- --------------------
- -- Contract_Cases --
- --------------------
+ Next (S);
+ end loop;
- -- pragma Contract_Cases (CONTRACT_CASE_LIST);
+ Set_Is_Asynchronous (Nm);
+ end Process_Async_Pragma;
- -- CONTRACT_CASE_LIST ::= CONTRACT_CASE {, CONTRACT_CASE}
+ -- Start of processing for pragma Asynchronous
- -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
+ begin
+ Check_Ada_83_Warning;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
- -- CASE_GUARD ::= boolean_EXPRESSION | others
+ if Debug_Flag_U then
+ return;
+ end if;
- -- CONSEQUENCE ::= boolean_EXPRESSION
+ C_Ent := Cunit_Entity (Current_Sem_Unit);
+ Analyze (Get_Pragma_Arg (Arg1));
+ Nm := Entity (Get_Pragma_Arg (Arg1));
- when Pragma_Contract_Cases => Contract_Cases : declare
- Others_Seen : Boolean := False;
+ if not Is_Remote_Call_Interface (C_Ent)
+ and then not Is_Remote_Types (C_Ent)
+ then
+ -- This pragma should only appear in an RCI or Remote Types
+ -- unit (RM E.4.1(4)).
- procedure Analyze_Contract_Case (Contract_Case : Node_Id);
- -- Verify the legality of a single contract case
+ Error_Pragma
+ ("pragma% not in Remote_Call_Interface or Remote_Types unit");
+ end if;
- procedure Chain_Contract_Cases (Subp_Id : Entity_Id);
- -- Chain pragma Contract_Cases to the contract of a subprogram.
- -- Subp_Id is the related subprogram.
+ if Ekind (Nm) = E_Procedure
+ and then Nkind (Parent (Nm)) = N_Procedure_Specification
+ then
+ if not Is_Remote_Call_Interface (Nm) then
+ Error_Pragma_Arg
+ ("pragma% cannot be applied on non-remote procedure",
+ Arg1);
+ end if;
- ---------------------------
- -- Analyze_Contract_Case --
- ---------------------------
+ L := Parameter_Specifications (Parent (Nm));
+ Process_Async_Pragma;
+ return;
- procedure Analyze_Contract_Case (Contract_Case : Node_Id) is
- Case_Guard : Node_Id;
- Extra_Guard : Node_Id;
+ elsif Ekind (Nm) = E_Function then
+ Error_Pragma_Arg
+ ("pragma% cannot be applied to function", Arg1);
- begin
- if Nkind (Contract_Case) = N_Component_Association then
- Case_Guard := First (Choices (Contract_Case));
+ elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
+ if Is_Record_Type (Nm) then
- -- Each contract case must have exactly on case guard
+ -- A record type that is the Equivalent_Type for a remote
+ -- access-to-subprogram type.
- Extra_Guard := Next (Case_Guard);
+ N := Declaration_Node (Corresponding_Remote_Type (Nm));
- if Present (Extra_Guard) then
- Error_Pragma_Arg
- ("contract case may have only one case guard",
- Extra_Guard);
- end if;
+ else
+ -- A non-expanded RAS type (distribution is not enabled)
- -- Check the placement of "others" (if available)
+ N := Declaration_Node (Nm);
+ end if;
- if Nkind (Case_Guard) = N_Others_Choice then
- if Others_Seen then
- Error_Pragma_Arg
- ("only one others choice allowed in pragma %",
- Case_Guard);
- else
- Others_Seen := True;
- end if;
+ if Nkind (N) = N_Full_Type_Declaration
+ and then Nkind (Type_Definition (N)) =
+ N_Access_Procedure_Definition
+ then
+ L := Parameter_Specifications (Type_Definition (N));
+ Process_Async_Pragma;
- elsif Others_Seen then
- Error_Pragma_Arg
- ("others must be the last choice in pragma %", N);
+ if Is_Asynchronous (Nm)
+ and then Expander_Active
+ and then Get_PCS_Name /= Name_No_DSA
+ then
+ RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
end if;
- -- The contract case is malformed
-
else
Error_Pragma_Arg
- ("wrong syntax in contract case", Contract_Case);
+ ("pragma% cannot reference access-to-function type",
+ Arg1);
end if;
- end Analyze_Contract_Case;
- --------------------------
- -- Chain_Contract_Cases --
- --------------------------
+ -- Only other possibility is Access-to-class-wide type
- procedure Chain_Contract_Cases (Subp_Id : Entity_Id) is
- CTC : Node_Id;
+ elsif Is_Access_Type (Nm)
+ and then Is_Class_Wide_Type (Designated_Type (Nm))
+ then
+ Check_First_Subtype (Arg1);
+ Set_Is_Asynchronous (Nm);
+ if Expander_Active then
+ RACW_Type_Is_Asynchronous (Nm);
+ end if;
- begin
- Check_Duplicate_Pragma (Subp_Id);
- CTC := Spec_CTC_List (Contract (Subp_Id));
- while Present (CTC) loop
- if Chars (Pragma_Identifier (CTC)) = Pname then
- Error_Msg_Name_1 := Pname;
- Error_Msg_Sloc := Sloc (CTC);
+ else
+ Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
+ end if;
+ end Asynchronous;
- if From_Aspect_Specification (CTC) then
- Error_Msg_NE
- ("aspect% for & previously given#", N, Subp_Id);
- else
- Error_Msg_NE
- ("pragma% for & duplicates pragma#", N, Subp_Id);
- end if;
+ ------------
+ -- Atomic --
+ ------------
+
+ -- pragma Atomic (LOCAL_NAME);
+
+ when Pragma_Atomic =>
+ Process_Atomic_Shared_Volatile;
+
+ -----------------------
+ -- Atomic_Components --
+ -----------------------
+
+ -- pragma Atomic_Components (array_LOCAL_NAME);
+
+ -- This processing is shared by Volatile_Components
+
+ when Pragma_Atomic_Components |
+ Pragma_Volatile_Components =>
+
+ Atomic_Components : declare
+ E_Id : Node_Id;
+ E : Entity_Id;
+ D : Node_Id;
+ K : Node_Kind;
+
+ begin
+ Check_Ada_83_Warning;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
- raise Pragma_Exit;
- end if;
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
- CTC := Next_Pragma (CTC);
- end loop;
+ E := Entity (E_Id);
- -- Prepend pragma Contract_Cases to the contract
+ Check_Duplicate_Pragma (E);
- Set_Next_Pragma (N, Spec_CTC_List (Contract (Subp_Id)));
- Set_Spec_CTC_List (Contract (Subp_Id), N);
- end Chain_Contract_Cases;
+ if Rep_Item_Too_Early (E, N)
+ or else
+ Rep_Item_Too_Late (E, N)
+ then
+ return;
+ end if;
- -- Local variables
+ D := Declaration_Node (E);
+ K := Nkind (D);
- Context : constant Node_Id := Parent (N);
- All_Cases : Node_Id;
- Decl : Node_Id;
- Contract_Case : Node_Id;
- Subp_Decl : Node_Id;
- Subp_Id : Entity_Id;
+ if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
+ or else
+ ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
+ and then Nkind (D) = N_Object_Declaration
+ and then Nkind (Object_Definition (D)) =
+ N_Constrained_Array_Definition)
+ then
+ -- The flag is set on the object, or on the base type
- -- Start of processing for Contract_Cases
+ if Nkind (D) /= N_Object_Declaration then
+ E := Base_Type (E);
+ end if;
- begin
- GNAT_Pragma;
- Check_Arg_Count (1);
+ Set_Has_Volatile_Components (E);
- -- Check the placement of the pragma
+ if Prag_Id = Pragma_Atomic_Components then
+ Set_Has_Atomic_Components (E);
+ end if;
- if not Is_List_Member (N) then
- Pragma_Misplaced;
+ else
+ Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
end if;
+ end Atomic_Components;
- -- Aspect/pragma Contract_Cases may be associated with a library
- -- level subprogram.
+ --------------------
+ -- Attach_Handler --
+ --------------------
- if Nkind (Context) = N_Compilation_Unit_Aux then
- Subp_Decl := Unit (Parent (Context));
+ -- pragma Attach_Handler (handler_NAME, EXPRESSION);
- if not Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
- N_Subprogram_Declaration)
- then
- Pragma_Misplaced;
- end if;
+ when Pragma_Attach_Handler =>
+ Check_Ada_83_Warning;
+ Check_No_Identifiers;
+ Check_Arg_Count (2);
- Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
+ if No_Run_Time_Mode then
+ Error_Msg_CRT ("Attach_Handler pragma", N);
+ else
+ Check_Interrupt_Or_Attach_Handler;
- -- The aspect/pragma appears in a subprogram body. The placement
- -- is legal when the body acts as a spec.
+ -- The expression that designates the attribute may depend on a
+ -- discriminant, and is therefore a per-object expression, to
+ -- be expanded in the init proc. If expansion is enabled, then
+ -- perform semantic checks on a copy only.
- elsif Nkind (Context) = N_Subprogram_Body then
- Subp_Id := Defining_Unit_Name (Specification (Context));
+ if Expander_Active then
+ declare
+ Temp : constant Node_Id :=
+ New_Copy_Tree (Get_Pragma_Arg (Arg2));
+ begin
+ Set_Parent (Temp, N);
+ Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
+ end;
- if Ekind (Subp_Id) = E_Subprogram_Body then
- Error_Pragma
- ("pragma % may not appear in a subprogram body that acts "
- & "as completion");
+ else
+ Analyze (Get_Pragma_Arg (Arg2));
+ Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID));
end if;
- -- Nested subprogram case, the aspect/pragma must apply to the
- -- subprogram spec.
+ Process_Interrupt_Or_Attach_Handler;
+ end if;
- else
- Decl := N;
- while Present (Prev (Decl)) loop
- Decl := Prev (Decl);
+ --------------------
+ -- C_Pass_By_Copy --
+ --------------------
- if Nkind (Decl) in N_Generic_Declaration then
- Subp_Decl := Decl;
- else
- Subp_Decl := Original_Node (Decl);
- end if;
+ -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
- -- Skip prior pragmas
+ when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
+ Arg : Node_Id;
+ Val : Uint;
- if Nkind (Subp_Decl) = N_Pragma then
- null;
+ begin
+ GNAT_Pragma;
+ Check_Valid_Configuration_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, "max_size");
- -- Skip internally generated code
+ Arg := Get_Pragma_Arg (Arg1);
+ Check_Arg_Is_Static_Expression (Arg, Any_Integer);
- elsif not Comes_From_Source (Subp_Decl) then
- null;
+ Val := Expr_Value (Arg);
- -- We have found the related subprogram
+ if Val <= 0 then
+ Error_Pragma_Arg
+ ("maximum size for pragma% must be positive", Arg1);
- elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
- N_Subprogram_Declaration)
- then
- exit;
+ elsif UI_Is_In_Int_Range (Val) then
+ Default_C_Record_Mechanism := UI_To_Int (Val);
- else
- Pragma_Misplaced;
- end if;
- end loop;
+ -- If a giant value is given, Int'Last will do well enough.
+ -- If sometime someone complains that a record larger than
+ -- two gigabytes is not copied, we will worry about it then!
- Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
+ else
+ Default_C_Record_Mechanism := Mechanism_Type'Last;
end if;
+ end C_Pass_By_Copy;
- All_Cases := Expression (Arg1);
+ -----------
+ -- Check --
+ -----------
- -- Multiple contract cases appear in aggregate form
+ -- pragma Check ([Name =>] CHECK_KIND,
+ -- [Check =>] Boolean_EXPRESSION
+ -- [,[Message =>] String_EXPRESSION]);
- if Nkind (All_Cases) = N_Aggregate then
- if No (Component_Associations (All_Cases)) then
- Error_Pragma ("wrong syntax for pragma %");
+ -- CHECK_KIND ::= IDENTIFIER |
+ -- Pre'Class |
+ -- Post'Class |
+ -- Invariant'Class |
+ -- Type_Invariant'Class
- -- Individual contract cases appear as component associations
+ -- The identifiers Assertions and Statement_Assertions are not
+ -- allowed, since they have special meaning for Check_Policy.
- else
- Contract_Case := First (Component_Associations (All_Cases));
- while Present (Contract_Case) loop
- Analyze_Contract_Case (Contract_Case);
+ when Pragma_Check => Check : declare
+ Expr : Node_Id;
+ Eloc : Source_Ptr;
+ Cname : Name_Id;
+ Str : Node_Id;
- Next (Contract_Case);
- end loop;
- end if;
- else
- Error_Pragma ("wrong syntax for pragma %");
+ Check_On : Boolean;
+ -- Set True if category of assertions referenced by Name enabled
+
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (2);
+ Check_At_Most_N_Arguments (3);
+ Check_Optional_Identifier (Arg1, Name_Name);
+ Check_Optional_Identifier (Arg2, Name_Check);
+
+ if Arg_Count = 3 then
+ Check_Optional_Identifier (Arg3, Name_Message);
+ Str := Get_Pragma_Arg (Arg3);
end if;
- Chain_Contract_Cases (Subp_Id);
- end Contract_Cases;
+ Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
+ Check_Arg_Is_Identifier (Arg1);
+ Cname := Chars (Get_Pragma_Arg (Arg1));
- ----------------
- -- Controlled --
- ----------------
+ -- Check forbidden name Assertions or Statement_Assertions
- -- pragma Controlled (first_subtype_LOCAL_NAME);
+ case Cname is
+ when Name_Assertions =>
+ Error_Pragma_Arg
+ ("""Assertions"" is not allowed as a check kind "
+ & "for pragma%", Arg1);
- when Pragma_Controlled => Controlled : declare
- Arg : Node_Id;
+ when Name_Statement_Assertions =>
+ Error_Pragma_Arg
+ ("""Statement_Assertions"" is not allowed as a check kind "
+ & "for pragma%", Arg1);
- begin
- Check_No_Identifiers;
- Check_Arg_Count (1);
- Check_Arg_Is_Local_Name (Arg1);
- Arg := Get_Pragma_Arg (Arg1);
+ when others =>
+ null;
+ end case;
- if not Is_Entity_Name (Arg)
- or else not Is_Access_Type (Entity (Arg))
- then
- Error_Pragma_Arg ("pragma% requires access type", Arg1);
- else
- Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
- end if;
- end Controlled;
+ -- Set Check_On to indicate check status
- ----------------
- -- Convention --
- ----------------
+ -- If this comes from an aspect, we have already taken care of
+ -- the policy active when the aspect was analyzed, and Is_Ignored
+ -- is set appropriately already.
- -- pragma Convention ([Convention =>] convention_IDENTIFIER,
- -- [Entity =>] LOCAL_NAME);
+ if From_Aspect_Specification (N) then
+ Check_On := not Is_Ignored (N);
- when Pragma_Convention => Convention : declare
- C : Convention_Id;
- E : Entity_Id;
- pragma Warnings (Off, C);
- pragma Warnings (Off, E);
- begin
- Check_Arg_Order ((Name_Convention, Name_Entity));
- Check_Ada_83_Warning;
- Check_Arg_Count (2);
- Process_Convention (C, E);
- end Convention;
+ -- Otherwise check the status right now
- ---------------------------
- -- Convention_Identifier --
- ---------------------------
+ else
+ case Check_Kind (Cname) is
+ when Name_Ignore =>
+ Check_On := False;
- -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
- -- [Convention =>] convention_IDENTIFIER);
+ when Name_Check =>
+ Check_On := True;
- when Pragma_Convention_Identifier => Convention_Identifier : declare
- Idnam : Name_Id;
- Cname : Name_Id;
+ -- For disable, rewrite pragma as null statement and skip
+ -- rest of the analysis of the pragma.
- begin
- GNAT_Pragma;
- Check_Arg_Order ((Name_Name, Name_Convention));
- Check_Arg_Count (2);
- Check_Optional_Identifier (Arg1, Name_Name);
- Check_Optional_Identifier (Arg2, Name_Convention);
- Check_Arg_Is_Identifier (Arg1);
- Check_Arg_Is_Identifier (Arg2);
- Idnam := Chars (Get_Pragma_Arg (Arg1));
- Cname := Chars (Get_Pragma_Arg (Arg2));
+ when Name_Disable =>
+ Rewrite (N, Make_Null_Statement (Loc));
+ Analyze (N);
+ raise Pragma_Exit;
- if Is_Convention_Name (Cname) then
- Record_Convention_Identifier
- (Idnam, Get_Convention_Id (Cname));
- else
- Error_Pragma_Arg
- ("second arg for % pragma must be convention", Arg2);
+ -- No other possibilities
+
+ when others =>
+ raise Program_Error;
+ end case;
end if;
- end Convention_Identifier;
- ---------------
- -- CPP_Class --
- ---------------
+ -- If check kind was not Disable, then continue pragma analysis
- -- pragma CPP_Class ([Entity =>] local_NAME)
+ Expr := Get_Pragma_Arg (Arg2);
- when Pragma_CPP_Class => CPP_Class : declare
- begin
- GNAT_Pragma;
+ -- Deal with SCO generation
- if Warn_On_Obsolescent_Feature then
- Error_Msg_N
- ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
- & "effect; replace it by pragma import?j?", N);
- end if;
+ case Cname is
+ when Name_Predicate |
+ Name_Invariant =>
- Check_Arg_Count (1);
+ -- Nothing to do: since checks occur in client units,
+ -- the SCO for the aspect in the declaration unit is
+ -- conservatively always enabled.
- Rewrite (N,
- Make_Pragma (Loc,
- Chars => Name_Import,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression => Make_Identifier (Loc, Name_CPP)),
- New_Copy (First (Pragma_Argument_Associations (N))))));
- Analyze (N);
- end CPP_Class;
+ null;
- ---------------------
- -- CPP_Constructor --
- ---------------------
+ when others =>
- -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
- -- [, [External_Name =>] static_string_EXPRESSION ]
- -- [, [Link_Name =>] static_string_EXPRESSION ]);
+ if Check_On and then not Split_PPC (N) then
- when Pragma_CPP_Constructor => CPP_Constructor : declare
- Elmt : Elmt_Id;
- Id : Entity_Id;
- Def_Id : Entity_Id;
- Tag_Typ : Entity_Id;
+ -- Mark pragma/aspect SCO as enabled
- begin
- GNAT_Pragma;
- Check_At_Least_N_Arguments (1);
- Check_At_Most_N_Arguments (3);
- Check_Optional_Identifier (Arg1, Name_Entity);
- Check_Arg_Is_Local_Name (Arg1);
+ Set_SCO_Pragma_Enabled (Loc);
+ end if;
+ end case;
- Id := Get_Pragma_Arg (Arg1);
- Find_Program_Unit_Name (Id);
+ -- Deal with analyzing the string argument.
- -- If we did not find the name, we are done
+ if Arg_Count = 3 then
- if Etype (Id) = Any_Type then
- return;
- end if;
+ -- If checks are not on we don't want any expansion (since
+ -- such expansion would not get properly deleted) but
+ -- we do want to analyze (to get proper references).
+ -- The Preanalyze_And_Resolve routine does just what we want
- Def_Id := Entity (Id);
+ if not Check_On then
+ Preanalyze_And_Resolve (Str, Standard_String);
- -- Check if already defined as constructor
+ -- Otherwise we need a proper analysis and expansion
- if Is_Constructor (Def_Id) then
- Error_Msg_N
- ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
- return;
+ else
+ Analyze_And_Resolve (Str, Standard_String);
+ end if;
end if;
- if Ekind (Def_Id) = E_Function
- and then (Is_CPP_Class (Etype (Def_Id))
- or else (Is_Class_Wide_Type (Etype (Def_Id))
- and then
- Is_CPP_Class (Root_Type (Etype (Def_Id)))))
- then
- if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
- Error_Msg_N
- ("'C'P'P constructor must be defined in the scope of "
- & "its returned type", Arg1);
- end if;
+ -- Now you might think we could just do the same with the Boolean
+ -- expression if checks are off (and expansion is on) and then
+ -- rewrite the check as a null statement. This would work but we
+ -- would lose the useful warnings about an assertion being bound
+ -- to fail even if assertions are turned off.
- if Arg_Count >= 2 then
- Set_Imported (Def_Id);
- Set_Is_Public (Def_Id);
- Process_Interface_Name (Def_Id, Arg2, Arg3);
- end if;
+ -- So instead we wrap the boolean expression in an if statement
+ -- that looks like:
- Set_Has_Completion (Def_Id);
- Set_Is_Constructor (Def_Id);
- Set_Convention (Def_Id, Convention_CPP);
+ -- if False and then condition then
+ -- null;
+ -- end if;
- -- Imported C++ constructors are not dispatching primitives
- -- because in C++ they don't have a dispatch table slot.
- -- However, in Ada the constructor has the profile of a
- -- function that returns a tagged type and therefore it has
- -- been treated as a primitive operation during semantic
- -- analysis. We now remove it from the list of primitive
- -- operations of the type.
+ -- The reason we do this rewriting during semantic analysis
+ -- rather than as part of normal expansion is that we cannot
+ -- analyze and expand the code for the boolean expression
+ -- directly, or it may cause insertion of actions that would
+ -- escape the attempt to suppress the check code.
- if Is_Tagged_Type (Etype (Def_Id))
- and then not Is_Class_Wide_Type (Etype (Def_Id))
- and then Is_Dispatching_Operation (Def_Id)
- then
- Tag_Typ := Etype (Def_Id);
+ -- Note that the Sloc for the if statement corresponds to the
+ -- argument condition, not the pragma itself. The reason for
+ -- this is that we may generate a warning if the condition is
+ -- False at compile time, and we do not want to delete this
+ -- warning when we delete the if statement.
- Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
- while Present (Elmt) and then Node (Elmt) /= Def_Id loop
- Next_Elmt (Elmt);
- end loop;
+ if Expander_Active and not Check_On then
+ Eloc := Sloc (Expr);
- Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
- Set_Is_Dispatching_Operation (Def_Id, False);
- end if;
+ Rewrite (N,
+ Make_If_Statement (Eloc,
+ Condition =>
+ Make_And_Then (Eloc,
+ Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
+ Right_Opnd => Expr),
+ Then_Statements => New_List (
+ Make_Null_Statement (Eloc))));
- -- For backward compatibility, if the constructor returns a
- -- class wide type, and we internally change the return type to
- -- the corresponding root type.
+ In_Assertion_Expr := In_Assertion_Expr + 1;
+ Analyze (N);
+ In_Assertion_Expr := In_Assertion_Expr - 1;
+
+ -- Check is active or expansion not active. In these cases we can
+ -- just go ahead and analyze the boolean with no worries.
- if Is_Class_Wide_Type (Etype (Def_Id)) then
- Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
- end if;
else
- Error_Pragma_Arg
- ("pragma% requires function returning a 'C'P'P_Class type",
- Arg1);
+ In_Assertion_Expr := In_Assertion_Expr + 1;
+ Analyze_And_Resolve (Expr, Any_Boolean);
+ In_Assertion_Expr := In_Assertion_Expr - 1;
end if;
- end CPP_Constructor;
+ end Check;
- -----------------
- -- CPP_Virtual --
- -----------------
+ --------------------------
+ -- Check_Float_Overflow --
+ --------------------------
- when Pragma_CPP_Virtual => CPP_Virtual : declare
- begin
+ -- pragma Check_Float_Overflow;
+
+ when Pragma_Check_Float_Overflow =>
+ GNAT_Pragma;
+ Check_Valid_Configuration_Pragma;
+ Check_Arg_Count (0);
+ Check_Float_Overflow := True;
+
+ ----------------
+ -- Check_Name --
+ ----------------
+
+ -- pragma Check_Name (check_IDENTIFIER);
+
+ when Pragma_Check_Name =>
+ Check_No_Identifiers;
GNAT_Pragma;
+ Check_Valid_Configuration_Pragma;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Identifier (Arg1);
+
+ declare
+ Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
+
+ begin
+ for J in Check_Names.First .. Check_Names.Last loop
+ if Check_Names.Table (J) = Nam then
+ return;
+ end if;
+ end loop;
+
+ Check_Names.Append (Nam);
+ end;
+
+ ------------------
+ -- Check_Policy --
+ ------------------
+
+ -- This is the old style syntax, which is still allowed in all modes:
- if Warn_On_Obsolescent_Feature then
- Error_Msg_N
- ("'G'N'A'T pragma cpp'_virtual is now obsolete and has no "
- & "effect?j?", N);
- end if;
- end CPP_Virtual;
+ -- pragma Check_Policy ([Name =>] CHECK_KIND
+ -- [Policy =>] POLICY_IDENTIFIER);
- ----------------
- -- CPP_Vtable --
- ----------------
+ -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
- when Pragma_CPP_Vtable => CPP_Vtable : declare
- begin
- GNAT_Pragma;
+ -- CHECK_KIND ::= IDENTIFIER |
+ -- Pre'Class |
+ -- Post'Class |
+ -- Type_Invariant'Class |
+ -- Invariant'Class
- if Warn_On_Obsolescent_Feature then
- Error_Msg_N
- ("'G'N'A'T pragma cpp'_vtable is now obsolete and has no "
- & "effect?j?", N);
- end if;
- end CPP_Vtable;
+ -- This is the new style syntax, compatible with Assertion_Policy
+ -- and also allowed in all modes.
- ---------
- -- CPU --
- ---------
+ -- Pragma Check_Policy (
+ -- CHECK_KIND => POLICY_IDENTIFIER
+ -- {, CHECK_KIND => POLICY_IDENTIFIER});
- -- pragma CPU (EXPRESSION);
+ -- Note: the identifiers Name and Policy are not allowed as
+ -- Check_Kind values. This avoids ambiguities between the old and
+ -- new form syntax.
- when Pragma_CPU => CPU : declare
- P : constant Node_Id := Parent (N);
- Arg : Node_Id;
- Ent : Entity_Id;
+ when Pragma_Check_Policy => Check_Policy : declare
+ Kind : Node_Id;
begin
- Ada_2012_Pragma;
- Check_No_Identifiers;
- Check_Arg_Count (1);
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (1);
- -- Subprogram case
+ -- A Check_Policy pragma can appear either as a configuration
+ -- pragma, or in a declarative part or a package spec (see RM
+ -- 11.5(5) for rules for Suppress/Unsuppress which are also
+ -- followed for Check_Policy).
- if Nkind (P) = N_Subprogram_Body then
- Check_In_Main_Program;
+ if not Is_Configuration_Pragma then
+ Check_Is_In_Decl_Part_Or_Package_Spec;
+ end if;
- Arg := Get_Pragma_Arg (Arg1);
- Analyze_And_Resolve (Arg, Any_Integer);
+ -- Figure out if we have the old or new syntax. We have the
+ -- old syntax if the first argument has no identifier, or the
+ -- identifier is Name.
- Ent := Defining_Unit_Name (Specification (P));
+ if Nkind (Arg1) /= N_Pragma_Argument_Association
+ or else Nam_In (Chars (Arg1), No_Name, Name_Name)
+ then
+ -- Old syntax
- if Nkind (Ent) = N_Defining_Program_Unit_Name then
- Ent := Defining_Identifier (Ent);
+ Check_Arg_Count (2);
+ Check_Optional_Identifier (Arg1, Name_Name);
+ Kind := Get_Pragma_Arg (Arg1);
+ Rewrite_Assertion_Kind (Kind);
+ Check_Arg_Is_Identifier (Arg1);
+
+ -- Check forbidden check kind
+
+ if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
+ Error_Msg_Name_2 := Chars (Kind);
+ Error_Pragma_Arg
+ ("pragma% does not allow% as check name", Arg1);
end if;
- -- Must be static
+ -- Check policy
- if not Is_Static_Expression (Arg) then
- Flag_Non_Static_Expr
- ("main subprogram affinity is not static!", Arg);
- raise Pragma_Exit;
+ Check_Optional_Identifier (Arg2, Name_Policy);
+ Check_Arg_Is_One_Of
+ (Arg2,
+ Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
- -- If constraint error, then we already signalled an error
+ -- And chain pragma on the Check_Policy_List for search
- elsif Raises_Constraint_Error (Arg) then
- null;
+ Set_Next_Pragma (N, Opt.Check_Policy_List);
+ Opt.Check_Policy_List := N;
- -- Otherwise check in range
+ -- For the new syntax, what we do is to convert each argument to
+ -- an old syntax equivalent. We do that because we want to chain
+ -- old style Check_Policy pragmas for the search (we don't want
+ -- to have to deal with multiple arguments in the search).
- else
- declare
- CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
- -- This is the entity System.Multiprocessors.CPU_Range;
+ else
+ declare
+ Arg : Node_Id;
+ Argx : Node_Id;
+ LocP : Source_Ptr;
- Val : constant Uint := Expr_Value (Arg);
+ begin
+ Arg := Arg1;
+ while Present (Arg) loop
+ LocP := Sloc (Arg);
+ Argx := Get_Pragma_Arg (Arg);
- begin
- if Val < Expr_Value (Type_Low_Bound (CPU_Id))
- or else
- Val > Expr_Value (Type_High_Bound (CPU_Id))
+ -- Kind must be specified
+
+ if Nkind (Arg) /= N_Pragma_Argument_Association
+ or else Chars (Arg) = No_Name
then
Error_Pragma_Arg
- ("main subprogram CPU is out of range", Arg1);
+ ("missing assertion kind for pragma%", Arg);
end if;
- end;
- end if;
-
- Set_Main_CPU
- (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
-
- -- Task case
- elsif Nkind (P) = N_Task_Definition then
- Arg := Get_Pragma_Arg (Arg1);
- Ent := Defining_Identifier (Parent (P));
+ -- Construct equivalent old form syntax Check_Policy
+ -- pragma and insert it to get remaining checks.
- -- The expression must be analyzed in the special manner
- -- described in "Handling of Default and Per-Object
- -- Expressions" in sem.ads.
+ Insert_Action (N,
+ Make_Pragma (LocP,
+ Chars => Name_Check_Policy,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (LocP,
+ Expression =>
+ Make_Identifier (LocP, Chars (Arg))),
+ Make_Pragma_Argument_Association (Sloc (Argx),
+ Expression => Argx))));
- Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
+ Arg := Next (Arg);
+ end loop;
- -- Anything else is incorrect
+ -- Rewrite original Check_Policy pragma to null, since we
+ -- have converted it into a series of old syntax pragmas.
- else
- Pragma_Misplaced;
+ Rewrite (N, Make_Null_Statement (Loc));
+ Analyze (N);
+ end;
end if;
+ end Check_Policy;
- -- Check duplicate pragma before we chain the pragma in the Rep
- -- Item chain of Ent.
+ ---------------------
+ -- CIL_Constructor --
+ ---------------------
- Check_Duplicate_Pragma (Ent);
- Record_Rep_Item (Ent, N);
- end CPU;
+ -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
- -----------
- -- Debug --
- -----------
+ -- Processing for this pragma is shared with Java_Constructor
- -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
+ -------------
+ -- Comment --
+ -------------
- when Pragma_Debug => Debug : declare
- Cond : Node_Id;
- Call : Node_Id;
+ -- pragma Comment (static_string_EXPRESSION)
- begin
- GNAT_Pragma;
+ -- Processing for pragma Comment shares the circuitry for pragma
+ -- Ident. The only differences are that Ident enforces a limit of 31
+ -- characters on its argument, and also enforces limitations on
+ -- placement for DEC compatibility. Pragma Comment shares neither of
+ -- these restrictions.
- -- The condition for executing the call is that the expander
- -- is active and that we are not ignoring this debug pragma.
+ -------------------
+ -- Common_Object --
+ -------------------
- Cond :=
- New_Occurrence_Of
- (Boolean_Literals
- (Expander_Active and then not Is_Ignored (N)),
- Loc);
+ -- pragma Common_Object (
+ -- [Internal =>] LOCAL_NAME
+ -- [, [External =>] EXTERNAL_SYMBOL]
+ -- [, [Size =>] EXTERNAL_SYMBOL]);
- if not Is_Ignored (N) then
- Set_SCO_Pragma_Enabled (Loc);
- end if;
+ -- Processing for this pragma is shared with Psect_Object
- if Arg_Count = 2 then
- Cond :=
- Make_And_Then (Loc,
- Left_Opnd => Relocate_Node (Cond),
- Right_Opnd => Get_Pragma_Arg (Arg1));
- Call := Get_Pragma_Arg (Arg2);
- else
- Call := Get_Pragma_Arg (Arg1);
- end if;
+ ------------------------
+ -- Compile_Time_Error --
+ ------------------------
- if Nkind_In (Call,
- N_Indexed_Component,
- N_Function_Call,
- N_Identifier,
- N_Expanded_Name,
- N_Selected_Component)
- then
- -- If this pragma Debug comes from source, its argument was
- -- parsed as a name form (which is syntactically identical).
- -- In a generic context a parameterless call will be left as
- -- an expanded name (if global) or selected_component if local.
- -- Change it to a procedure call statement now.
+ -- pragma Compile_Time_Error
+ -- (boolean_EXPRESSION, static_string_EXPRESSION);
- Change_Name_To_Procedure_Call_Statement (Call);
+ when Pragma_Compile_Time_Error =>
+ GNAT_Pragma;
+ Process_Compile_Time_Warning_Or_Error;
- elsif Nkind (Call) = N_Procedure_Call_Statement then
+ --------------------------
+ -- Compile_Time_Warning --
+ --------------------------
- -- Already in the form of a procedure call statement: nothing
- -- to do (could happen in case of an internally generated
- -- pragma Debug).
+ -- pragma Compile_Time_Warning
+ -- (boolean_EXPRESSION, static_string_EXPRESSION);
- null;
+ when Pragma_Compile_Time_Warning =>
+ GNAT_Pragma;
+ Process_Compile_Time_Warning_Or_Error;
+
+ -------------------
+ -- Compiler_Unit --
+ -------------------
- else
- -- All other cases: diagnose error
+ when Pragma_Compiler_Unit =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+ Set_Is_Compiler_Unit (Get_Source_Unit (N));
- Error_Msg
- ("argument of pragma ""Debug"" is not procedure call",
- Sloc (Call));
- return;
- end if;
+ -----------------------------
+ -- Complete_Representation --
+ -----------------------------
- -- Rewrite into a conditional with an appropriate condition. We
- -- wrap the procedure call in a block so that overhead from e.g.
- -- use of the secondary stack does not generate execution overhead
- -- for suppressed conditions.
+ -- pragma Complete_Representation;
- -- Normally the analysis that follows will freeze the subprogram
- -- being called. However, if the call is to a null procedure,
- -- we want to freeze it before creating the block, because the
- -- analysis that follows may be done with expansion disabled, in
- -- which case the body will not be generated, leading to spurious
- -- errors.
+ when Pragma_Complete_Representation =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
- if Nkind (Call) = N_Procedure_Call_Statement
- and then Is_Entity_Name (Name (Call))
- then
- Analyze (Name (Call));
- Freeze_Before (N, Entity (Name (Call)));
+ if Nkind (Parent (N)) /= N_Record_Representation_Clause then
+ Error_Pragma
+ ("pragma & must appear within record representation clause");
end if;
- Rewrite (N, Make_Implicit_If_Statement (N,
- Condition => Cond,
- Then_Statements => New_List (
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Relocate_Node (Call)))))));
- Analyze (N);
- end Debug;
+ ----------------------------
+ -- Complex_Representation --
+ ----------------------------
- ------------------
- -- Debug_Policy --
- ------------------
+ -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
- -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
+ when Pragma_Complex_Representation => Complex_Representation : declare
+ E_Id : Entity_Id;
+ E : Entity_Id;
+ Ent : Entity_Id;
- when Pragma_Debug_Policy =>
+ begin
GNAT_Pragma;
Check_Arg_Count (1);
- Check_No_Identifiers;
- Check_Arg_Is_Identifier (Arg1);
-
- -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
- -- rewrite it that way, and let the rest of the checking come
- -- from analyzing the rewritten pragma.
-
- Rewrite (N,
- Make_Pragma (Loc,
- Chars => Name_Check_Policy,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression => Make_Identifier (Loc, Name_Debug)),
-
- Make_Pragma_Argument_Association (Loc,
- Expression => Get_Pragma_Arg (Arg1)))));
- Analyze (N);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
- -------------
- -- Depends --
- -------------
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
- -- pragma Depends (DEPENDENCY_RELATION);
+ E := Entity (E_Id);
- -- DEPENDENCY_RELATION ::=
- -- null
- -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
+ if not Is_Record_Type (E) then
+ Error_Pragma_Arg
+ ("argument for pragma% must be record type", Arg1);
+ end if;
- -- DEPENDENCY_CLAUSE ::=
- -- OUTPUT_LIST =>[+] INPUT_LIST
- -- | NULL_DEPENDENCY_CLAUSE
+ Ent := First_Entity (E);
- -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
+ if No (Ent)
+ or else No (Next_Entity (Ent))
+ or else Present (Next_Entity (Next_Entity (Ent)))
+ or else not Is_Floating_Point_Type (Etype (Ent))
+ or else Etype (Ent) /= Etype (Next_Entity (Ent))
+ then
+ Error_Pragma_Arg
+ ("record for pragma% must have two fields of the same "
+ & "floating-point type", Arg1);
- -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
+ else
+ Set_Has_Complex_Representation (Base_Type (E));
- -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
+ -- We need to treat the type has having a non-standard
+ -- representation, for back-end purposes, even though in
+ -- general a complex will have the default representation
+ -- of a record with two real components.
- -- OUTPUT ::= NAME | FUNCTION_RESULT
- -- INPUT ::= NAME
+ Set_Has_Non_Standard_Rep (Base_Type (E));
+ end if;
+ end Complex_Representation;
- -- where FUNCTION_RESULT is a function Result attribute_reference
+ -------------------------
+ -- Component_Alignment --
+ -------------------------
- when Pragma_Depends => Depends : declare
- All_Inputs_Seen : Elist_Id := No_Elist;
- -- A list containing the entities of all the inputs processed so
- -- far. This Elist is populated with unique entities because the
- -- same input may appear in multiple input lists.
+ -- pragma Component_Alignment (
+ -- [Form =>] ALIGNMENT_CHOICE
+ -- [, [Name =>] type_LOCAL_NAME]);
+ --
+ -- ALIGNMENT_CHOICE ::=
+ -- Component_Size
+ -- | Component_Size_4
+ -- | Storage_Unit
+ -- | Default
- Global_Seen : Boolean := False;
- -- A flag set when pragma Global has been processed
+ when Pragma_Component_Alignment => Component_AlignmentP : declare
+ Args : Args_List (1 .. 2);
+ Names : constant Name_List (1 .. 2) := (
+ Name_Form,
+ Name_Name);
- Outputs_Seen : Elist_Id := No_Elist;
- -- A list containing the entities of all the outputs processed so
- -- far. The elements of this list may come from different output
- -- lists.
+ Form : Node_Id renames Args (1);
+ Name : Node_Id renames Args (2);
- Null_Output_Seen : Boolean := False;
- -- A flag used to track the legality of a null output
+ Atype : Component_Alignment_Kind;
+ Typ : Entity_Id;
- Result_Seen : Boolean := False;
- -- A flag set when Subp_Id'Result is processed
+ begin
+ GNAT_Pragma;
+ Gather_Associations (Names, Args);
- Subp_Id : Entity_Id;
- -- The entity of the subprogram subject to pragma Depends
-
- Subp_Inputs : Elist_Id := No_Elist;
- Subp_Outputs : Elist_Id := No_Elist;
- -- Two lists containing the full set of inputs and output of the
- -- related subprograms. Note that these lists contain both nodes
- -- and entities.
-
- procedure Analyze_Dependency_Clause
- (Clause : Node_Id;
- Is_Last : Boolean);
- -- Verify the legality of a single dependency clause. Flag Is_Last
- -- denotes whether Clause is the last clause in the relation.
-
- function Appears_In
- (List : Elist_Id;
- Item_Id : Entity_Id) return Boolean;
- -- Determine whether a particular item appears in a mixed list of
- -- nodes and entities.
-
- procedure Check_Function_Return;
- -- Verify that Funtion'Result appears as one of the outputs
-
- procedure Check_Mode
- (Item : Node_Id;
- Item_Id : Entity_Id;
- Is_Input : Boolean;
- Self_Ref : Boolean);
- -- Ensure that an item has a proper "in", "in out" or "out" mode
- -- depending on its function. If this is not the case, emit an
- -- error. Item and Item_Id denote the attributes of an item. Flag
- -- Is_Input should be set when item comes from an input list.
- -- Flag Self_Ref should be set when the item is an output and the
- -- dependency clause has operator "+".
-
- procedure Check_Usage
- (Subp_Items : Elist_Id;
- Used_Items : Elist_Id;
- Is_Input : Boolean);
- -- Verify that all items from Subp_Items appear in Used_Items.
- -- Emit an error if this is not the case.
-
- procedure Collect_Subprogram_Inputs_Outputs;
- -- Gather all inputs and outputs of the subprogram. These are the
- -- formal parameters and entities classified in pragma Global.
-
- procedure Normalize_Clause (Clause : Node_Id);
- -- Remove a self-dependency "+" from the input list of a clause.
- -- Depending on the contents of the relation, either split the
- -- the clause into multiple smaller clauses or perform the
- -- normalization in place.
-
- -------------------------------
- -- Analyze_Dependency_Clause --
- -------------------------------
-
- procedure Analyze_Dependency_Clause
- (Clause : Node_Id;
- Is_Last : Boolean)
- is
- procedure Analyze_Input_List (Inputs : Node_Id);
- -- Verify the legality of a single input list
-
- procedure Analyze_Input_Output
- (Item : Node_Id;
- Is_Input : Boolean;
- Self_Ref : Boolean;
- Top_Level : Boolean;
- Seen : in out Elist_Id;
- Null_Seen : in out Boolean);
- -- Verify the legality of a single input or output item. Flag
- -- Is_Input should be set whenever Item is an input, False when
- -- it denotes an output. Flag Self_Ref should be set when the
- -- item is an output and the dependency clause has a "+". Flag
- -- Top_Level should be set whenever Item appears immediately
- -- within an input or output list. Seen is a collection of all
- -- abstract states, variables and formals processed so far.
- -- Flag Null_Seen denotes whether a null input or output has
- -- been encountered.
-
- ------------------------
- -- Analyze_Input_List --
- ------------------------
-
- procedure Analyze_Input_List (Inputs : Node_Id) is
- Inputs_Seen : Elist_Id := No_Elist;
- -- A list containing the entities of all inputs that appear
- -- in the current input list.
-
- Null_Input_Seen : Boolean := False;
- -- A flag used to track the legality of a null input
-
- Input : Node_Id;
+ if No (Form) then
+ Error_Pragma ("missing Form argument for pragma%");
+ end if;
- begin
- -- Multiple inputs appear as an aggregate
+ Check_Arg_Is_Identifier (Form);
- if Nkind (Inputs) = N_Aggregate then
- if Present (Component_Associations (Inputs)) then
- Error_Msg_N
- ("nested dependency relations not allowed", Inputs);
-
- elsif Present (Expressions (Inputs)) then
- Input := First (Expressions (Inputs));
- while Present (Input) loop
- Analyze_Input_Output
- (Item => Input,
- Is_Input => True,
- Self_Ref => False,
- Top_Level => False,
- Seen => Inputs_Seen,
- Null_Seen => Null_Input_Seen);
-
- Next (Input);
- end loop;
+ -- Get proper alignment, note that Default = Component_Size on all
+ -- machines we have so far, and we want to set this value rather
+ -- than the default value to indicate that it has been explicitly
+ -- set (and thus will not get overridden by the default component
+ -- alignment for the current scope)
- else
- Error_Msg_N
- ("malformed input dependency list", Inputs);
- end if;
+ if Chars (Form) = Name_Component_Size then
+ Atype := Calign_Component_Size;
- -- Process a solitary input
+ elsif Chars (Form) = Name_Component_Size_4 then
+ Atype := Calign_Component_Size_4;
- else
- Analyze_Input_Output
- (Item => Inputs,
- Is_Input => True,
- Self_Ref => False,
- Top_Level => False,
- Seen => Inputs_Seen,
- Null_Seen => Null_Input_Seen);
- end if;
+ elsif Chars (Form) = Name_Default then
+ Atype := Calign_Component_Size;
- -- Detect an illegal dependency clause of the form
+ elsif Chars (Form) = Name_Storage_Unit then
+ Atype := Calign_Storage_Unit;
- -- (null =>[+] null)
+ else
+ Error_Pragma_Arg
+ ("invalid Form parameter for pragma%", Form);
+ end if;
- if Null_Output_Seen and then Null_Input_Seen then
- Error_Msg_N
- ("null dependency clause cannot have a null input list",
- Inputs);
- end if;
- end Analyze_Input_List;
-
- --------------------------
- -- Analyze_Input_Output --
- --------------------------
-
- procedure Analyze_Input_Output
- (Item : Node_Id;
- Is_Input : Boolean;
- Self_Ref : Boolean;
- Top_Level : Boolean;
- Seen : in out Elist_Id;
- Null_Seen : in out Boolean)
- is
- Is_Output : constant Boolean := not Is_Input;
- Grouped : Node_Id;
- Item_Id : Entity_Id;
+ -- Case with no name, supplied, affects scope table entry
- begin
- -- Multiple input or output items appear as an aggregate
+ if No (Name) then
+ Scope_Stack.Table
+ (Scope_Stack.Last).Component_Alignment_Default := Atype;
- if Nkind (Item) = N_Aggregate then
- if not Top_Level then
- Error_Msg_N
- ("nested grouping of items not allowed", Item);
+ -- Case of name supplied
- elsif Present (Component_Associations (Item)) then
- Error_Msg_N
- ("nested dependency relations not allowed", Item);
-
- -- Recursively analyze the grouped items
-
- elsif Present (Expressions (Item)) then
- Grouped := First (Expressions (Item));
- while Present (Grouped) loop
- Analyze_Input_Output
- (Item => Grouped,
- Is_Input => Is_Input,
- Self_Ref => Self_Ref,
- Top_Level => False,
- Seen => Seen,
- Null_Seen => Null_Seen);
-
- Next (Grouped);
- end loop;
+ else
+ Check_Arg_Is_Local_Name (Name);
+ Find_Type (Name);
+ Typ := Entity (Name);
- else
- Error_Msg_N ("malformed dependency list", Item);
- end if;
+ if Typ = Any_Type
+ or else Rep_Item_Too_Early (Typ, N)
+ then
+ return;
+ else
+ Typ := Underlying_Type (Typ);
+ end if;
- -- Process Function'Result in the context of a dependency
- -- clause.
+ if not Is_Record_Type (Typ)
+ and then not Is_Array_Type (Typ)
+ then
+ Error_Pragma_Arg
+ ("Name parameter of pragma% must identify record or "
+ & "array type", Name);
+ end if;
- elsif Nkind (Item) = N_Attribute_Reference
- and then Attribute_Name (Item) = Name_Result
- then
- -- It is sufficent to analyze the prefix of 'Result in
- -- order to establish legality of the attribute.
+ -- An explicit Component_Alignment pragma overrides an
+ -- implicit pragma Pack, but not an explicit one.
- Analyze (Prefix (Item));
+ if not Has_Pragma_Pack (Base_Type (Typ)) then
+ Set_Is_Packed (Base_Type (Typ), False);
+ Set_Component_Alignment (Base_Type (Typ), Atype);
+ end if;
+ end if;
+ end Component_AlignmentP;
- -- The prefix of 'Result must denote the function for
- -- which aspect/pragma Depends applies.
+ --------------------
+ -- Contract_Cases --
+ --------------------
- if not Is_Entity_Name (Prefix (Item))
- or else Ekind (Subp_Id) /= E_Function
- or else Entity (Prefix (Item)) /= Subp_Id
- then
- Error_Msg_Name_1 := Name_Result;
- Error_Msg_N
- ("prefix of attribute % must denote the enclosing "
- & "function", Item);
+ -- pragma Contract_Cases (CONTRACT_CASE_LIST);
- -- Function'Result is allowed to appear on the output
- -- side of a dependency clause.
+ -- CONTRACT_CASE_LIST ::= CONTRACT_CASE {, CONTRACT_CASE}
- elsif Is_Input then
- Error_Msg_N
- ("function result cannot act as input", Item);
+ -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
- else
- Result_Seen := True;
- end if;
+ -- CASE_GUARD ::= boolean_EXPRESSION | others
- -- Detect multiple uses of null in a single dependency list
- -- or throughout the whole relation. Verify the placement of
- -- a null output list relative to the other clauses.
+ -- CONSEQUENCE ::= boolean_EXPRESSION
- elsif Nkind (Item) = N_Null then
- if Null_Seen then
- Error_Msg_N
- ("multiple null dependency relations not allowed",
- Item);
- else
- Null_Seen := True;
+ when Pragma_Contract_Cases => Contract_Cases : declare
+ Others_Seen : Boolean := False;
- if Is_Output and then not Is_Last then
- Error_Msg_N
- ("null output list must be the last clause in "
- & "a dependency relation", Item);
- end if;
- end if;
+ procedure Analyze_Contract_Case (Contract_Case : Node_Id);
+ -- Verify the legality of a single contract case
- -- Default case
+ procedure Chain_Contract_Cases (Subp_Id : Entity_Id);
+ -- Chain pragma Contract_Cases to the contract of a subprogram.
+ -- Subp_Id is the related subprogram.
- else
- Analyze (Item);
+ ---------------------------
+ -- Analyze_Contract_Case --
+ ---------------------------
- -- Find the entity of the item. If this is a renaming,
- -- climb the renaming chain to reach the root object.
- -- Renamings of non-entire objects do not yield an
- -- entity (Empty).
+ procedure Analyze_Contract_Case (Contract_Case : Node_Id) is
+ Case_Guard : Node_Id;
+ Extra_Guard : Node_Id;
- Item_Id := Entity_Of (Item);
+ begin
+ if Nkind (Contract_Case) = N_Component_Association then
+ Case_Guard := First (Choices (Contract_Case));
- if Present (Item_Id) then
- if Ekind_In (Item_Id, E_Abstract_State,
- E_In_Parameter,
- E_In_Out_Parameter,
- E_Out_Parameter,
- E_Variable)
- then
- -- Ensure that the item is of the correct mode
- -- depending on its function.
+ -- Each contract case must have exactly on case guard
- Check_Mode (Item, Item_Id, Is_Input, Self_Ref);
+ Extra_Guard := Next (Case_Guard);
- -- Detect multiple uses of the same state, variable
- -- or formal parameter. If this is not the case,
- -- add the item to the list of processed relations.
+ if Present (Extra_Guard) then
+ Error_Pragma_Arg
+ ("contract case may have only one case guard",
+ Extra_Guard);
+ end if;
- if Contains (Seen, Item_Id) then
- Error_Msg_N ("duplicate use of item", Item);
- else
- Add_Item (Item_Id, Seen);
- end if;
+ -- Check the placement of "others" (if available)
- -- Detect an illegal use of an input related to a
- -- null output. Such input items cannot appear in
- -- other input lists.
+ if Nkind (Case_Guard) = N_Others_Choice then
+ if Others_Seen then
+ Error_Pragma_Arg
+ ("only one others choice allowed in pragma %",
+ Case_Guard);
+ else
+ Others_Seen := True;
+ end if;
- if Null_Output_Seen
- and then Contains (All_Inputs_Seen, Item_Id)
- then
- Error_Msg_N
- ("input of a null output list appears in "
- & "multiple input lists", Item);
- else
- Add_Item (Item_Id, All_Inputs_Seen);
- end if;
+ elsif Others_Seen then
+ Error_Pragma_Arg
+ ("others must be the last choice in pragma %", N);
+ end if;
- -- When the item renames an entire object, replace
- -- the item with a reference to the object.
+ -- The contract case is malformed
- if Present (Renamed_Object (Entity (Item))) then
- Rewrite (Item,
- New_Reference_To (Item_Id, Sloc (Item)));
- Analyze (Item);
- end if;
+ else
+ Error_Pragma_Arg
+ ("wrong syntax in contract case", Contract_Case);
+ end if;
+ end Analyze_Contract_Case;
- -- All other input/output items are illegal
+ --------------------------
+ -- Chain_Contract_Cases --
+ --------------------------
- else
- Error_Msg_N
- ("item must denote variable, state or formal "
- & "parameter", Item);
- end if;
+ procedure Chain_Contract_Cases (Subp_Id : Entity_Id) is
+ CTC : Node_Id;
- -- All other input/output items are illegal
+ begin
+ Check_Duplicate_Pragma (Subp_Id);
+ CTC := Contract_Test_Cases (Contract (Subp_Id));
+ while Present (CTC) loop
+ if Chars (Pragma_Identifier (CTC)) = Pname then
+ 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_Id);
else
- Error_Msg_N
- ("item must denote variable, state or formal "
- & "parameter", Item);
+ Error_Msg_NE
+ ("pragma% for & duplicates pragma#", N, Subp_Id);
end if;
- end if;
- end Analyze_Input_Output;
-
- -- Local variables
- Inputs : Node_Id;
- Output : Node_Id;
- Self_Ref : Boolean;
-
- -- Start of processing for Analyze_Dependency_Clause
+ raise Pragma_Exit;
+ end if;
- begin
- Inputs := Expression (Clause);
- Self_Ref := False;
+ CTC := Next_Pragma (CTC);
+ end loop;
- -- An input list with a self-dependency appears as operator "+"
- -- where the actuals inputs are the right operand.
+ -- Prepend pragma Contract_Cases to the contract
- if Nkind (Inputs) = N_Op_Plus then
- Inputs := Right_Opnd (Inputs);
- Self_Ref := True;
- end if;
+ Add_Contract_Item (N, Subp_Id);
+ end Chain_Contract_Cases;
- -- Process the output_list of a dependency_clause
+ -- Local variables
- Output := First (Choices (Clause));
- while Present (Output) loop
- Analyze_Input_Output
- (Item => Output,
- Is_Input => False,
- Self_Ref => Self_Ref,
- Top_Level => True,
- Seen => Outputs_Seen,
- Null_Seen => Null_Output_Seen);
-
- Next (Output);
- end loop;
+ Context : constant Node_Id := Parent (N);
+ All_Cases : Node_Id;
+ Decl : Node_Id;
+ Contract_Case : Node_Id;
+ Subp_Decl : Node_Id;
+ Subp_Id : Entity_Id;
- -- Process the input_list of a dependency_clause
+ -- Start of processing for Contract_Cases
- Analyze_Input_List (Inputs);
- end Analyze_Dependency_Clause;
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
- ----------------
- -- Appears_In --
- ----------------
+ -- Check the placement of the pragma
- function Appears_In
- (List : Elist_Id;
- Item_Id : Entity_Id) return Boolean
- is
- Elmt : Elmt_Id;
- Id : Entity_Id;
+ if not Is_List_Member (N) then
+ Pragma_Misplaced;
+ end if;
- begin
- if Present (List) then
- Elmt := First_Elmt (List);
- while Present (Elmt) loop
- if Nkind (Node (Elmt)) = N_Defining_Identifier then
- Id := Node (Elmt);
- else
- Id := Entity (Node (Elmt));
- end if;
+ -- Aspect/pragma Contract_Cases may be associated with a library
+ -- level subprogram.
- if Id = Item_Id then
- return True;
- end if;
+ if Nkind (Context) = N_Compilation_Unit_Aux then
+ Subp_Decl := Unit (Parent (Context));
- Next_Elmt (Elmt);
- end loop;
+ if not Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
+ N_Subprogram_Declaration)
+ then
+ Pragma_Misplaced;
end if;
- return False;
- end Appears_In;
+ Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
- ----------------------------
- -- Check_Function_Return --
- ----------------------------
+ -- The aspect/pragma appears in a subprogram body. The placement
+ -- is legal when the body acts as a spec.
- procedure Check_Function_Return is
- begin
- if Ekind (Subp_Id) = E_Function and then not Result_Seen then
- Error_Msg_NE
- ("result of & must appear in exactly one output list",
- N, Subp_Id);
+ elsif Nkind (Context) = N_Subprogram_Body then
+ Subp_Id := Defining_Unit_Name (Specification (Context));
+
+ if not Acts_As_Spec (Context) then
+ Error_Pragma
+ ("pragma % may not appear in a subprogram body that acts "
+ & "as completion");
end if;
- end Check_Function_Return;
- ----------------
- -- Check_Mode --
- ----------------
+ -- Nested subprogram case, the aspect/pragma must apply to the
+ -- subprogram spec.
- procedure Check_Mode
- (Item : Node_Id;
- Item_Id : Entity_Id;
- Is_Input : Boolean;
- Self_Ref : Boolean)
- is
- begin
- -- Input
+ else
+ Decl := N;
+ while Present (Prev (Decl)) loop
+ Decl := Prev (Decl);
- if Is_Input then
- if Ekind (Item_Id) = E_Out_Parameter
- or else (Global_Seen
- and then not Appears_In (Subp_Inputs, Item_Id))
- then
- Error_Msg_NE
- ("item & must have mode in or in out", Item, Item_Id);
+ if Nkind (Decl) in N_Generic_Declaration then
+ Subp_Decl := Decl;
+ else
+ Subp_Decl := Original_Node (Decl);
end if;
- -- Self-referential output
+ -- Skip prior pragmas
- elsif Self_Ref then
+ if Nkind (Subp_Decl) = N_Pragma then
+ null;
- -- A self-referential state or variable must appear in both
- -- input and output lists of a subprogram.
+ -- Skip internally generated code
- if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
- if Global_Seen
- and then not
- (Appears_In (Subp_Inputs, Item_Id)
- and then
- Appears_In (Subp_Outputs, Item_Id))
- then
- Error_Msg_NE
- ("item & must have mode in out", Item, Item_Id);
- end if;
+ elsif not Comes_From_Source (Subp_Decl) then
+ null;
- -- Self-referential parameter
+ -- We have found the related subprogram
- elsif Ekind (Item_Id) /= E_In_Out_Parameter then
- Error_Msg_NE
- ("item & must have mode in out", Item, Item_Id);
+ elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
+ N_Subprogram_Declaration)
+ then
+ exit;
+
+ else
+ Pragma_Misplaced;
end if;
+ end loop;
- -- Regular output
+ Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
+ end if;
- elsif Ekind (Item_Id) = E_In_Parameter
- or else
- (Global_Seen
- and then not Appears_In (Subp_Outputs, Item_Id))
- then
- Error_Msg_NE
- ("item & must have mode out or in out", Item, Item_Id);
- end if;
- end Check_Mode;
+ All_Cases := Expression (Arg1);
- -----------------
- -- Check_Usage --
- -----------------
+ -- Multiple contract cases appear in aggregate form
- procedure Check_Usage
- (Subp_Items : Elist_Id;
- Used_Items : Elist_Id;
- Is_Input : Boolean)
- is
- procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id);
- -- Emit an error concerning the erroneous usage of an item
+ if Nkind (All_Cases) = N_Aggregate then
+ if No (Component_Associations (All_Cases)) then
+ Error_Pragma ("wrong syntax for pragma %");
- -----------------
- -- Usage_Error --
- -----------------
+ -- Individual contract cases appear as component associations
- procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is
- begin
- if Is_Input then
- Error_Msg_NE
- ("item & must appear in at least one input list of "
- & "aspect Depends", Item, Item_Id);
- else
- Error_Msg_NE
- ("item & must appear in exactly one output list of "
- & "aspect Depends", Item, Item_Id);
- end if;
- end Usage_Error;
+ else
+ Contract_Case := First (Component_Associations (All_Cases));
+ while Present (Contract_Case) loop
+ Analyze_Contract_Case (Contract_Case);
- -- Local variables
+ Next (Contract_Case);
+ end loop;
+ end if;
+ else
+ Error_Pragma ("wrong syntax for pragma %");
+ end if;
+
+ Chain_Contract_Cases (Subp_Id);
+ end Contract_Cases;
+
+ ----------------
+ -- Controlled --
+ ----------------
- Elmt : Elmt_Id;
- Item : Node_Id;
- Item_Id : Entity_Id;
+ -- pragma Controlled (first_subtype_LOCAL_NAME);
- -- Start of processing for Check_Usage
+ when Pragma_Controlled => Controlled : declare
+ Arg : Node_Id;
- begin
- if No (Subp_Items) then
- return;
- end if;
+ begin
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+ Arg := Get_Pragma_Arg (Arg1);
- -- Each input or output of the subprogram must appear in a
- -- dependency relation.
+ if not Is_Entity_Name (Arg)
+ or else not Is_Access_Type (Entity (Arg))
+ then
+ Error_Pragma_Arg ("pragma% requires access type", Arg1);
+ else
+ Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
+ end if;
+ end Controlled;
- Elmt := First_Elmt (Subp_Items);
- while Present (Elmt) loop
- Item := Node (Elmt);
+ ----------------
+ -- Convention --
+ ----------------
- if Nkind (Item) = N_Defining_Identifier then
- Item_Id := Item;
- else
- Item_Id := Entity (Item);
- end if;
+ -- pragma Convention ([Convention =>] convention_IDENTIFIER,
+ -- [Entity =>] LOCAL_NAME);
- -- The item does not appear in a dependency
+ when Pragma_Convention => Convention : declare
+ C : Convention_Id;
+ E : Entity_Id;
+ pragma Warnings (Off, C);
+ pragma Warnings (Off, E);
+ begin
+ Check_Arg_Order ((Name_Convention, Name_Entity));
+ Check_Ada_83_Warning;
+ Check_Arg_Count (2);
+ Process_Convention (C, E);
+ end Convention;
- if not Contains (Used_Items, Item_Id) then
- if Is_Formal (Item_Id) then
- Usage_Error (Item, Item_Id);
+ ---------------------------
+ -- Convention_Identifier --
+ ---------------------------
- -- States and global variables are not used properly only
- -- when the subprogram is subject to pragma Global.
+ -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
+ -- [Convention =>] convention_IDENTIFIER);
- elsif Global_Seen then
- Usage_Error (Item, Item_Id);
- end if;
- end if;
+ when Pragma_Convention_Identifier => Convention_Identifier : declare
+ Idnam : Name_Id;
+ Cname : Name_Id;
- Next_Elmt (Elmt);
- end loop;
- end Check_Usage;
+ begin
+ GNAT_Pragma;
+ Check_Arg_Order ((Name_Name, Name_Convention));
+ Check_Arg_Count (2);
+ Check_Optional_Identifier (Arg1, Name_Name);
+ Check_Optional_Identifier (Arg2, Name_Convention);
+ Check_Arg_Is_Identifier (Arg1);
+ Check_Arg_Is_Identifier (Arg2);
+ Idnam := Chars (Get_Pragma_Arg (Arg1));
+ Cname := Chars (Get_Pragma_Arg (Arg2));
- ---------------------------------------
- -- Collect_Subprogram_Inputs_Outputs --
- ---------------------------------------
+ if Is_Convention_Name (Cname) then
+ Record_Convention_Identifier
+ (Idnam, Get_Convention_Id (Cname));
+ else
+ Error_Pragma_Arg
+ ("second arg for % pragma must be convention", Arg2);
+ end if;
+ end Convention_Identifier;
- procedure Collect_Subprogram_Inputs_Outputs is
- procedure Collect_Global_List
- (List : Node_Id;
- Mode : Name_Id := Name_Input);
- -- Collect all relevant items from a global list
+ ---------------
+ -- CPP_Class --
+ ---------------
- -------------------------
- -- Collect_Global_List --
- -------------------------
+ -- pragma CPP_Class ([Entity =>] local_NAME)
- procedure Collect_Global_List
- (List : Node_Id;
- Mode : Name_Id := Name_Input)
- is
- procedure Collect_Global_Item
- (Item : Node_Id;
- Mode : Name_Id);
- -- Add an item to the proper subprogram input or output
- -- collection.
-
- -------------------------
- -- Collect_Global_Item --
- -------------------------
-
- procedure Collect_Global_Item
- (Item : Node_Id;
- Mode : Name_Id)
- is
- begin
- if Nam_In (Mode, Name_In_Out, Name_Input) then
- Add_Item (Item, Subp_Inputs);
- end if;
+ when Pragma_CPP_Class => CPP_Class : declare
+ begin
+ GNAT_Pragma;
- if Nam_In (Mode, Name_In_Out, Name_Output) then
- Add_Item (Item, Subp_Outputs);
- end if;
- end Collect_Global_Item;
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
+ & "effect; replace it by pragma import?j?", N);
+ end if;
- -- Local variables
+ Check_Arg_Count (1);
- Assoc : Node_Id;
- Item : Node_Id;
+ Rewrite (N,
+ Make_Pragma (Loc,
+ Chars => Name_Import,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Name_CPP)),
+ New_Copy (First (Pragma_Argument_Associations (N))))));
+ Analyze (N);
+ end CPP_Class;
- -- Start of processing for Collect_Global_List
+ ---------------------
+ -- CPP_Constructor --
+ ---------------------
- begin
- -- Single global item declaration
+ -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
+ -- [, [External_Name =>] static_string_EXPRESSION ]
+ -- [, [Link_Name =>] static_string_EXPRESSION ]);
- if Nkind_In (List, N_Identifier, N_Selected_Component) then
- Collect_Global_Item (List, Mode);
+ when Pragma_CPP_Constructor => CPP_Constructor : declare
+ Elmt : Elmt_Id;
+ Id : Entity_Id;
+ Def_Id : Entity_Id;
+ Tag_Typ : Entity_Id;
- -- Simple global list or moded global list declaration
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (1);
+ Check_At_Most_N_Arguments (3);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
- else
- if Present (Expressions (List)) then
- Item := First (Expressions (List));
- while Present (Item) loop
- Collect_Global_Item (Item, Mode);
+ Id := Get_Pragma_Arg (Arg1);
+ Find_Program_Unit_Name (Id);
- Next (Item);
- end loop;
+ -- If we did not find the name, we are done
- else
- Assoc := First (Component_Associations (List));
- while Present (Assoc) loop
- Collect_Global_List
- (List => Expression (Assoc),
- Mode => Chars (First (Choices (Assoc))));
+ if Etype (Id) = Any_Type then
+ return;
+ end if;
- Next (Assoc);
- end loop;
- end if;
- end if;
- end Collect_Global_List;
+ Def_Id := Entity (Id);
- -- Local variables
+ -- Check if already defined as constructor
- Formal : Entity_Id;
- Global : Node_Id;
- List : Node_Id;
+ if Is_Constructor (Def_Id) then
+ Error_Msg_N
+ ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
+ return;
+ end if;
- -- Start of processing for Collect_Subprogram_Inputs_Outputs
+ if Ekind (Def_Id) = E_Function
+ and then (Is_CPP_Class (Etype (Def_Id))
+ or else (Is_Class_Wide_Type (Etype (Def_Id))
+ and then
+ Is_CPP_Class (Root_Type (Etype (Def_Id)))))
+ then
+ if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
+ Error_Msg_N
+ ("'C'P'P constructor must be defined in the scope of "
+ & "its returned type", Arg1);
+ end if;
- begin
- -- Process all formal parameters
+ if Arg_Count >= 2 then
+ Set_Imported (Def_Id);
+ Set_Is_Public (Def_Id);
+ Process_Interface_Name (Def_Id, Arg2, Arg3);
+ end if;
- Formal := First_Formal (Subp_Id);
- while Present (Formal) loop
- if Ekind_In (Formal, E_In_Out_Parameter,
- E_In_Parameter)
- then
- Add_Item (Formal, Subp_Inputs);
- end if;
+ Set_Has_Completion (Def_Id);
+ Set_Is_Constructor (Def_Id);
+ Set_Convention (Def_Id, Convention_CPP);
- if Ekind_In (Formal, E_In_Out_Parameter,
- E_Out_Parameter)
- then
- Add_Item (Formal, Subp_Outputs);
- end if;
+ -- Imported C++ constructors are not dispatching primitives
+ -- because in C++ they don't have a dispatch table slot.
+ -- However, in Ada the constructor has the profile of a
+ -- function that returns a tagged type and therefore it has
+ -- been treated as a primitive operation during semantic
+ -- analysis. We now remove it from the list of primitive
+ -- operations of the type.
- Next_Formal (Formal);
- end loop;
+ if Is_Tagged_Type (Etype (Def_Id))
+ and then not Is_Class_Wide_Type (Etype (Def_Id))
+ and then Is_Dispatching_Operation (Def_Id)
+ then
+ Tag_Typ := Etype (Def_Id);
- -- If the subprogram is subject to pragma Global, traverse all
- -- global lists and gather the relevant items.
+ Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+ while Present (Elmt) and then Node (Elmt) /= Def_Id loop
+ Next_Elmt (Elmt);
+ end loop;
- Global := Find_Aspect (Subp_Id, Aspect_Global);
- if Present (Global) then
- Global_Seen := True;
+ Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
+ Set_Is_Dispatching_Operation (Def_Id, False);
+ end if;
- -- Retrieve the pragma as it contains the analyzed lists
+ -- For backward compatibility, if the constructor returns a
+ -- class wide type, and we internally change the return type to
+ -- the corresponding root type.
- Global := Aspect_Rep_Item (Global);
+ if Is_Class_Wide_Type (Etype (Def_Id)) then
+ Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
+ end if;
+ else
+ Error_Pragma_Arg
+ ("pragma% requires function returning a 'C'P'P_Class type",
+ Arg1);
+ end if;
+ end CPP_Constructor;
- -- The pragma may not have been analyzed because of the
- -- arbitrary declaration order of aspects. Make sure that
- -- it is analyzed for the purposes of item extraction.
+ -----------------
+ -- CPP_Virtual --
+ -----------------
- if not Analyzed (Global) then
- Analyze (Global);
- end if;
+ when Pragma_CPP_Virtual => CPP_Virtual : declare
+ begin
+ GNAT_Pragma;
- List :=
- Expression (First (Pragma_Argument_Associations (Global)));
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("'G'N'A'T pragma cpp'_virtual is now obsolete and has no "
+ & "effect?j?", N);
+ end if;
+ end CPP_Virtual;
- -- Nothing to be done for a null global list
+ ----------------
+ -- CPP_Vtable --
+ ----------------
- if Nkind (List) /= N_Null then
- Collect_Global_List (List);
- end if;
- end if;
- end Collect_Subprogram_Inputs_Outputs;
+ when Pragma_CPP_Vtable => CPP_Vtable : declare
+ begin
+ GNAT_Pragma;
- ----------------------
- -- Normalize_Clause --
- ----------------------
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("'G'N'A'T pragma cpp'_vtable is now obsolete and has no "
+ & "effect?j?", N);
+ end if;
+ end CPP_Vtable;
- procedure Normalize_Clause (Clause : Node_Id) is
- procedure Create_Or_Modify_Clause
- (Output : Node_Id;
- Outputs : Node_Id;
- Inputs : Node_Id;
- After : Node_Id;
- In_Place : Boolean;
- Multiple : Boolean);
- -- Create a brand new clause to represent the self-reference
- -- or modify the input and/or output lists of an existing
- -- clause. Output denotes a self-referencial output. Outputs
- -- is the output list of a clause. Inputs is the input list
- -- of a clause. After denotes the clause after which the new
- -- clause is to be inserted. Flag In_Place should be set when
- -- normalizing the last output of an output list. Flag Multiple
- -- should be set when Output comes from a list with multiple
- -- items.
-
- -----------------------------
- -- Create_Or_Modify_Clause --
- -----------------------------
-
- procedure Create_Or_Modify_Clause
- (Output : Node_Id;
- Outputs : Node_Id;
- Inputs : Node_Id;
- After : Node_Id;
- In_Place : Boolean;
- Multiple : Boolean)
- is
- procedure Propagate_Output
- (Output : Node_Id;
- Inputs : Node_Id);
- -- Handle the various cases of output propagation to the
- -- input list. Output denotes a self-referencial output
- -- item. Inputs is the input list of a clause.
-
- ----------------------
- -- Propagate_Output --
- ----------------------
-
- procedure Propagate_Output
- (Output : Node_Id;
- Inputs : Node_Id)
- is
- function In_Input_List
- (Item : Entity_Id;
- Inputs : List_Id) return Boolean;
- -- Determine whether a particulat item appears in the
- -- input list of a clause.
-
- -------------------
- -- In_Input_List --
- -------------------
-
- function In_Input_List
- (Item : Entity_Id;
- Inputs : List_Id) return Boolean
- is
- Elmt : Node_Id;
+ ---------
+ -- CPU --
+ ---------
- begin
- Elmt := First (Inputs);
- while Present (Elmt) loop
- if Entity_Of (Elmt) = Item then
- return True;
- end if;
+ -- pragma CPU (EXPRESSION);
- Next (Elmt);
- end loop;
+ when Pragma_CPU => CPU : declare
+ P : constant Node_Id := Parent (N);
+ Arg : Node_Id;
+ Ent : Entity_Id;
- return False;
- end In_Input_List;
+ begin
+ Ada_2012_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
- -- Local variables
+ -- Subprogram case
- Output_Id : constant Entity_Id := Entity_Of (Output);
- Grouped : List_Id;
+ if Nkind (P) = N_Subprogram_Body then
+ Check_In_Main_Program;
- -- Start of processing for Propagate_Output
+ Arg := Get_Pragma_Arg (Arg1);
+ Analyze_And_Resolve (Arg, Any_Integer);
- begin
- -- The clause is of the form:
+ Ent := Defining_Unit_Name (Specification (P));
- -- (Output =>+ null)
+ if Nkind (Ent) = N_Defining_Program_Unit_Name then
+ Ent := Defining_Identifier (Ent);
+ end if;
- -- Remove the null input and replace it with a copy of
- -- the output:
+ -- Must be static
- -- (Output => Output)
+ if not Is_Static_Expression (Arg) then
+ Flag_Non_Static_Expr
+ ("main subprogram affinity is not static!", Arg);
+ raise Pragma_Exit;
- if Nkind (Inputs) = N_Null then
- Rewrite (Inputs, New_Copy_Tree (Output));
+ -- If constraint error, then we already signalled an error
- -- The clause is of the form:
+ elsif Raises_Constraint_Error (Arg) then
+ null;
- -- (Output =>+ (Input1, ..., InputN))
+ -- Otherwise check in range
- -- Determine whether the output is not already mentioned
- -- in the input list and if not, add it to the list of
- -- inputs:
+ else
+ declare
+ CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
+ -- This is the entity System.Multiprocessors.CPU_Range;
- -- (Output => (Output, Input1, ..., InputN))
+ Val : constant Uint := Expr_Value (Arg);
- elsif Nkind (Inputs) = N_Aggregate then
- Grouped := Expressions (Inputs);
+ begin
+ if Val < Expr_Value (Type_Low_Bound (CPU_Id))
+ or else
+ Val > Expr_Value (Type_High_Bound (CPU_Id))
+ then
+ Error_Pragma_Arg
+ ("main subprogram CPU is out of range", Arg1);
+ end if;
+ end;
+ end if;
- if not In_Input_List
- (Item => Output_Id,
- Inputs => Grouped)
- then
- Prepend_To (Grouped, New_Copy_Tree (Output));
- end if;
+ Set_Main_CPU
+ (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
- -- The clause is of the form:
+ -- Task case
- -- (Output =>+ Input)
+ elsif Nkind (P) = N_Task_Definition then
+ Arg := Get_Pragma_Arg (Arg1);
+ Ent := Defining_Identifier (Parent (P));
- -- If the input does not mention the output, group the
- -- two together:
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default and Per-Object
+ -- Expressions" in sem.ads.
- -- (Output => (Output, Input))
+ Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
- elsif Entity_Of (Inputs) /= Output_Id then
- Rewrite (Inputs,
- Make_Aggregate (Loc,
- Expressions => New_List (
- New_Copy_Tree (Output),
- New_Copy_Tree (Inputs))));
- end if;
- end Propagate_Output;
+ -- Anything else is incorrect
- -- Local variables
+ else
+ Pragma_Misplaced;
+ end if;
- Loc : constant Source_Ptr := Sloc (Output);
- Clause : Node_Id;
+ -- Check duplicate pragma before we chain the pragma in the Rep
+ -- Item chain of Ent.
- -- Start of processing for Create_Or_Modify_Clause
+ Check_Duplicate_Pragma (Ent);
+ Record_Rep_Item (Ent, N);
+ end CPU;
- begin
- -- A function result cannot depend on itself because it
- -- cannot appear in the input list of a relation.
+ -----------
+ -- Debug --
+ -----------
- if Nkind (Output) = N_Attribute_Reference
- and then Attribute_Name (Output) = Name_Result
- then
- Error_Msg_N
- ("function result cannot depend on itself", Output);
- return;
+ -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
- -- A null output depending on itself does not require any
- -- normalization.
+ when Pragma_Debug => Debug : declare
+ Cond : Node_Id;
+ Call : Node_Id;
- elsif Nkind (Output) = N_Null then
- return;
- end if;
+ begin
+ GNAT_Pragma;
- -- When performing the transformation in place, simply add
- -- the output to the list of inputs (if not already there).
- -- This case arises when dealing with the last output of an
- -- output list - we perform the normalization in place to
- -- avoid generating a malformed tree.
+ -- The condition for executing the call is that the expander
+ -- is active and that we are not ignoring this debug pragma.
- if In_Place then
- Propagate_Output (Output, Inputs);
+ Cond :=
+ New_Occurrence_Of
+ (Boolean_Literals
+ (Expander_Active and then not Is_Ignored (N)),
+ Loc);
- -- A list with multiple outputs is slowly trimmed until
- -- only one element remains. When this happens, replace
- -- the aggregate with the element itself.
+ if not Is_Ignored (N) then
+ Set_SCO_Pragma_Enabled (Loc);
+ end if;
- if Multiple then
- Remove (Output);
- Rewrite (Outputs, Output);
- end if;
+ if Arg_Count = 2 then
+ Cond :=
+ Make_And_Then (Loc,
+ Left_Opnd => Relocate_Node (Cond),
+ Right_Opnd => Get_Pragma_Arg (Arg1));
+ Call := Get_Pragma_Arg (Arg2);
+ else
+ Call := Get_Pragma_Arg (Arg1);
+ end if;
- -- Default case
+ if Nkind_In (Call,
+ N_Indexed_Component,
+ N_Function_Call,
+ N_Identifier,
+ N_Expanded_Name,
+ N_Selected_Component)
+ then
+ -- If this pragma Debug comes from source, its argument was
+ -- parsed as a name form (which is syntactically identical).
+ -- In a generic context a parameterless call will be left as
+ -- an expanded name (if global) or selected_component if local.
+ -- Change it to a procedure call statement now.
- else
- -- Unchain the output from its output list as it will
- -- appear in a new clause. Note that we cannot simply
- -- rewrite the output as null because this will violate
- -- the semantics of aspect/pragma Depends.
+ Change_Name_To_Procedure_Call_Statement (Call);
- Remove (Output);
+ elsif Nkind (Call) = N_Procedure_Call_Statement then
- -- Create a new clause of the form:
+ -- Already in the form of a procedure call statement: nothing
+ -- to do (could happen in case of an internally generated
+ -- pragma Debug).
- -- (Output => Inputs)
+ null;
- Clause :=
- Make_Component_Association (Loc,
- Choices => New_List (Output),
- Expression => New_Copy_Tree (Inputs));
+ else
+ -- All other cases: diagnose error
- -- The new clause contains replicated content that has
- -- already been analyzed. There is not need to reanalyze
- -- it or renormalize it again.
+ Error_Msg
+ ("argument of pragma ""Debug"" is not procedure call",
+ Sloc (Call));
+ return;
+ end if;
- Set_Analyzed (Clause);
+ -- Rewrite into a conditional with an appropriate condition. We
+ -- wrap the procedure call in a block so that overhead from e.g.
+ -- use of the secondary stack does not generate execution overhead
+ -- for suppressed conditions.
- Propagate_Output
- (Output => First (Choices (Clause)),
- Inputs => Expression (Clause));
+ -- Normally the analysis that follows will freeze the subprogram
+ -- being called. However, if the call is to a null procedure,
+ -- we want to freeze it before creating the block, because the
+ -- analysis that follows may be done with expansion disabled, in
+ -- which case the body will not be generated, leading to spurious
+ -- errors.
- Insert_After (After, Clause);
- end if;
- end Create_Or_Modify_Clause;
+ if Nkind (Call) = N_Procedure_Call_Statement
+ and then Is_Entity_Name (Name (Call))
+ then
+ Analyze (Name (Call));
+ Freeze_Before (N, Entity (Name (Call)));
+ end if;
- -- Local variables
+ Rewrite (N, Make_Implicit_If_Statement (N,
+ Condition => Cond,
+ Then_Statements => New_List (
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Relocate_Node (Call)))))));
+ Analyze (N);
+ end Debug;
- Outputs : constant Node_Id := First (Choices (Clause));
- Inputs : Node_Id;
- Last_Output : Node_Id;
- Next_Output : Node_Id;
- Output : Node_Id;
+ ------------------
+ -- Debug_Policy --
+ ------------------
- -- Start of processing for Normalize_Clause
+ -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
- begin
- -- A self-dependency appears as operator "+". Remove the "+"
- -- from the tree by moving the real inputs to their proper
- -- place.
+ when Pragma_Debug_Policy =>
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_Identifier (Arg1);
- if Nkind (Expression (Clause)) = N_Op_Plus then
- Rewrite
- (Expression (Clause), Right_Opnd (Expression (Clause)));
- Inputs := Expression (Clause);
+ -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
+ -- rewrite it that way, and let the rest of the checking come
+ -- from analyzing the rewritten pragma.
- -- Multiple outputs appear as an aggregate
+ Rewrite (N,
+ Make_Pragma (Loc,
+ Chars => Name_Check_Policy,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Name_Debug)),
- if Nkind (Outputs) = N_Aggregate then
- Last_Output := Last (Expressions (Outputs));
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Get_Pragma_Arg (Arg1)))));
+ Analyze (N);
- Output := First (Expressions (Outputs));
- while Present (Output) loop
+ -------------
+ -- Depends --
+ -------------
- -- Normalization may remove an output from its list,
- -- preserve the subsequent output now.
+ -- pragma Depends (DEPENDENCY_RELATION);
- Next_Output := Next (Output);
+ -- DEPENDENCY_RELATION ::=
+ -- null
+ -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
- Create_Or_Modify_Clause
- (Output => Output,
- Outputs => Outputs,
- Inputs => Inputs,
- After => Clause,
- In_Place => Output = Last_Output,
- Multiple => True);
+ -- DEPENDENCY_CLAUSE ::=
+ -- OUTPUT_LIST =>[+] INPUT_LIST
+ -- | NULL_DEPENDENCY_CLAUSE
- Output := Next_Output;
- end loop;
+ -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
- -- Solitary output
+ -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
- else
- Create_Or_Modify_Clause
- (Output => Outputs,
- Outputs => Empty,
- Inputs => Inputs,
- After => Empty,
- In_Place => True,
- Multiple => False);
- end if;
- end if;
- end Normalize_Clause;
+ -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
- -- Local variables
+ -- OUTPUT ::= NAME | FUNCTION_RESULT
+ -- INPUT ::= NAME
- Clause : Node_Id;
- Errors : Nat;
- Last_Clause : Node_Id;
- Subp_Decl : Node_Id;
+ -- where FUNCTION_RESULT is a function Result attribute_reference
- -- Start of processing for Depends
+ when Pragma_Depends => Depends : declare
+ Subp_Decl : Node_Id;
+ Subp_Id : Entity_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
-- Ensure the proper placement of the pragma. Depends must be
- -- associated with a subprogram declaration.
+ -- associated with a subprogram declaration or a body that acts
+ -- as a spec.
Subp_Decl := Parent (Corresponding_Aspect (N));
- if Nkind (Subp_Decl) /= N_Subprogram_Declaration then
+ if Nkind (Subp_Decl) /= N_Subprogram_Declaration
+ and then (Nkind (Subp_Decl) /= N_Subprogram_Body
+ or else not Acts_As_Spec (Subp_Decl))
+ then
Pragma_Misplaced;
return;
end if;
Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
- Clause := Expression (Arg1);
- -- Empty dependency list
+ -- The pragma is analyzed at the end of the declarative part which
+ -- contains the related subprogram. Reset the analyzed flag.
- if Nkind (Clause) = N_Null then
+ Set_Analyzed (N, False);
- -- Gather all states, variables and formal parameters that the
- -- subprogram may depend on. These items are obtained from the
- -- parameter profile or pragma Global (if available).
+ -- When the aspect/pragma appears on a subprogram body, perform
+ -- the full analysis now.
- Collect_Subprogram_Inputs_Outputs;
+ if Nkind (Subp_Decl) = N_Subprogram_Body then
+ Analyze_Depends_In_Decl_Part (N);
- -- Verify that every input or output of the subprogram appear
- -- in a dependency.
-
- Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
- Check_Usage (Subp_Outputs, Outputs_Seen, False);
- Check_Function_Return;
-
- -- Dependency clauses appear as component associations of an
- -- aggregate.
-
- elsif Nkind (Clause) = N_Aggregate
- and then Present (Component_Associations (Clause))
- then
- Last_Clause := Last (Component_Associations (Clause));
-
- -- Gather all states, variables and formal parameters that the
- -- subprogram may depend on. These items are obtained from the
- -- parameter profile or pragma Global (if available).
-
- Collect_Subprogram_Inputs_Outputs;
-
- -- Ensure that the formal parameters are visible when analyzing
- -- all clauses. This falls out of the general rule of aspects
- -- pertaining to subprogram declarations.
-
- Push_Scope (Subp_Id);
- Install_Formals (Subp_Id);
-
- Clause := First (Component_Associations (Clause));
- while Present (Clause) loop
- Errors := Serious_Errors_Detected;
-
- -- Normalization may create extra clauses that contain
- -- replicated input and output names. There is no need
- -- to reanalyze or renormalize these extra clauses.
-
- if not Analyzed (Clause) then
- Set_Analyzed (Clause);
-
- Analyze_Dependency_Clause
- (Clause => Clause,
- Is_Last => Clause = Last_Clause);
-
- -- Do not normalize an erroneous clause because the
- -- inputs or outputs may denote illegal items.
-
- if Errors = Serious_Errors_Detected then
- Normalize_Clause (Clause);
- end if;
- end if;
-
- Next (Clause);
- end loop;
-
- End_Scope;
-
- -- Verify that every input or output of the subprogram appear
- -- in a dependency.
-
- Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
- Check_Usage (Subp_Outputs, Outputs_Seen, False);
- Check_Function_Return;
-
- -- The top level dependency relation is malformed
+ -- Chain the pragma on the contract for further processing
else
- Error_Msg_N ("malformed dependency relation", Clause);
+ Add_Contract_Item (N, Subp_Id);
end if;
end Depends;
-- GLOBAL_ITEM ::= NAME
when Pragma_Global => Global : declare
- Subp_Id : Entity_Id;
-
- Seen : Elist_Id := No_Elist;
- -- A list containing the entities of all the items processed so
- -- far. It plays a role in detecting distinct entities.
-
- Contract_Seen : Boolean := False;
- In_Out_Seen : Boolean := False;
- Input_Seen : Boolean := False;
- Output_Seen : Boolean := False;
- -- Flags used to verify the consistency of modes
-
- procedure Analyze_Global_List
- (List : Node_Id;
- Global_Mode : Name_Id := Name_Input);
- -- Verify the legality of a single global list declaration.
- -- Global_Mode denotes the current mode in effect.
-
- -------------------------
- -- Analyze_Global_List --
- -------------------------
-
- procedure Analyze_Global_List
- (List : Node_Id;
- Global_Mode : Name_Id := Name_Input)
- is
- procedure Analyze_Global_Item
- (Item : Node_Id;
- Global_Mode : Name_Id);
- -- Verify the legality of a single global item declaration.
- -- Global_Mode denotes the current mode in effect.
-
- procedure Check_Duplicate_Mode
- (Mode : Node_Id;
- Status : in out Boolean);
- -- Flag Status denotes whether a particular mode has been seen
- -- while processing a global list. This routine verifies that
- -- Mode is not a duplicate mode and sets the flag Status.
-
- procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
- -- Mode denotes either In_Out or Output. Depending on the kind
- -- of the related subprogram, emit an error if those two modes
- -- apply to a function.
-
- -------------------------
- -- Analyze_Global_Item --
- -------------------------
-
- procedure Analyze_Global_Item
- (Item : Node_Id;
- Global_Mode : Name_Id)
- is
- Item_Id : Entity_Id;
-
- begin
- -- Detect one of the following cases
-
- -- with Global => (null, Name)
- -- with Global => (Name_1, null, Name_2)
- -- with Global => (Name, null)
-
- if Nkind (Item) = N_Null then
- Error_Msg_N
- ("cannot mix null and non-null global items", Item);
- return;
- end if;
-
- Analyze (Item);
-
- -- Find the entity of the item. If this is a renaming, climb
- -- the renaming chain to reach the root object. Renamings of
- -- non-entire objects do not yield an entity (Empty).
-
- Item_Id := Entity_Of (Item);
-
- if Present (Item_Id) then
-
- -- A global item cannot reference a formal parameter. Do
- -- this check first to provide a better error diagnostic.
-
- if Is_Formal (Item_Id) then
- Error_Msg_N
- ("global item cannot reference formal parameter",
- Item);
- return;
-
- -- The only legal references are those to abstract states
- -- and variables.
-
- elsif not Ekind_In (Item_Id, E_Abstract_State,
- E_Variable)
- then
- Error_Msg_N
- ("global item must denote variable or state", Item);
- return;
- end if;
-
- -- When the item renames an entire object, replace the
- -- item with a reference to the object.
-
- if Present (Renamed_Object (Entity (Item))) then
- Rewrite (Item,
- New_Reference_To (Item_Id, Sloc (Item)));
- Analyze (Item);
- end if;
-
- -- Some form of illegal construct masquerading as a name
-
- else
- Error_Msg_N
- ("global item must denote variable or state", Item);
- return;
- end if;
-
- -- The same entity might be referenced through various way.
- -- Check the entity of the item rather than the item itself.
-
- if Contains (Seen, Item_Id) then
- Error_Msg_N ("duplicate global item", Item);
-
- -- Add the entity of the current item to the list of
- -- processed items.
-
- else
- Add_Item (Item_Id, Seen);
- end if;
-
- if Ekind (Item_Id) = E_Abstract_State
- and then Is_Volatile_State (Item_Id)
- then
- -- A global item of mode In_Out or Output cannot denote a
- -- volatile Input state.
-
- if Is_Input_State (Item_Id)
- and then Nam_In (Global_Mode, Name_In_Out, Name_Output)
- then
- Error_Msg_N
- ("global item of mode In_Out or Output cannot "
- & "reference Volatile Input state", Item);
-
- -- A global item of mode In_Out or Input cannot reference
- -- a volatile Output state.
-
- elsif Is_Output_State (Item_Id)
- and then Nam_In (Global_Mode, Name_In_Out, Name_Input)
- then
- Error_Msg_N
- ("global item of mode In_Out or Input cannot "
- & "reference Volatile Output state", Item);
- end if;
- end if;
- end Analyze_Global_Item;
-
- --------------------------
- -- Check_Duplicate_Mode --
- --------------------------
-
- procedure Check_Duplicate_Mode
- (Mode : Node_Id;
- Status : in out Boolean)
- is
- begin
- if Status then
- Error_Msg_N ("duplicate global mode", Mode);
- end if;
-
- Status := True;
- end Check_Duplicate_Mode;
-
- ----------------------------------------
- -- Check_Mode_Restriction_In_Function --
- ----------------------------------------
-
- procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
- begin
- if Ekind (Subp_Id) = E_Function then
- Error_Msg_N
- ("global mode & not applicable to functions", Mode);
- end if;
- end Check_Mode_Restriction_In_Function;
-
- -- Local variables
-
- Assoc : Node_Id;
- Item : Node_Id;
- Mode : Node_Id;
-
- -- Start of processing for Analyze_Global_List
-
- begin
- -- Single global item declaration
-
- if Nkind_In (List, N_Identifier, N_Selected_Component) then
- Analyze_Global_Item (List, Global_Mode);
-
- -- Simple global list or moded global list declaration
-
- elsif Nkind (List) = N_Aggregate then
-
- -- The declaration of a simple global list appear as a
- -- collection of expressions.
-
- if Present (Expressions (List)) then
- if Present (Component_Associations (List)) then
- Error_Msg_N
- ("cannot mix moded and non-moded global lists",
- List);
- end if;
-
- Item := First (Expressions (List));
- while Present (Item) loop
- Analyze_Global_Item (Item, Global_Mode);
-
- Next (Item);
- end loop;
-
- -- The declaration of a moded global list appears as a
- -- collection of component associations where individual
- -- choices denote modes.
-
- elsif Present (Component_Associations (List)) then
- if Present (Expressions (List)) then
- Error_Msg_N
- ("cannot mix moded and non-moded global lists",
- List);
- end if;
-
- Assoc := First (Component_Associations (List));
- while Present (Assoc) loop
- Mode := First (Choices (Assoc));
-
- if Nkind (Mode) = N_Identifier then
- if Chars (Mode) = Name_Contract_In then
- Check_Duplicate_Mode (Mode, Contract_Seen);
-
- elsif Chars (Mode) = Name_In_Out then
- Check_Duplicate_Mode (Mode, In_Out_Seen);
- Check_Mode_Restriction_In_Function (Mode);
-
- elsif Chars (Mode) = Name_Input then
- Check_Duplicate_Mode (Mode, Input_Seen);
-
- elsif Chars (Mode) = Name_Output then
- Check_Duplicate_Mode (Mode, Output_Seen);
- Check_Mode_Restriction_In_Function (Mode);
-
- else
- Error_Msg_N ("invalid mode selector", Mode);
- end if;
-
- else
- Error_Msg_N ("invalid mode selector", Mode);
- end if;
-
- -- Items in a moded list appear as a collection of
- -- expressions. Reuse the existing machinery to
- -- analyze them.
-
- Analyze_Global_List
- (List => Expression (Assoc),
- Global_Mode => Chars (Mode));
-
- Next (Assoc);
- end loop;
-
- -- Something went horribly wrong, we have a malformed tree
-
- else
- raise Program_Error;
- end if;
-
- -- Any other attempt to declare a global item is erroneous
-
- else
- Error_Msg_N ("malformed global list declaration", List);
- end if;
- end Analyze_Global_List;
-
- -- Local variables
-
- List : Node_Id;
- Subp : Node_Id;
-
- -- Start of processing for Global
+ Subp_Decl : Node_Id;
+ Subp_Id : Entity_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
-- Ensure the proper placement of the pragma. Global must be
- -- associated with a subprogram declaration.
+ -- associated with a subprogram declaration or a body that acts
+ -- as a spec.
- Subp := Parent (Corresponding_Aspect (N));
+ Subp_Decl := Parent (Corresponding_Aspect (N));
- if Nkind (Subp) /= N_Subprogram_Declaration then
+ if Nkind (Subp_Decl) /= N_Subprogram_Declaration
+ and then (Nkind (Subp_Decl) /= N_Subprogram_Body
+ or else not Acts_As_Spec (Subp_Decl))
+ then
Pragma_Misplaced;
return;
end if;
- Subp_Id := Defining_Unit_Name (Specification (Subp));
- List := Expression (Arg1);
-
- -- There is nothing to be done for a null global list
+ Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
- if Nkind (List) = N_Null then
- null;
+ -- The pragma is analyzed at the end of the declarative part which
+ -- contains the related subprogram. Reset the analyzed flag.
- -- Analyze the various forms of global lists and items. Note that
- -- some of these may be malformed in which case the analysis emits
- -- error messages.
+ Set_Analyzed (N, False);
- else
- -- Ensure that the formal parameters are visible when
- -- processing an item. This falls out of the general rule of
- -- aspects pertaining to subprogram declarations.
+ -- When the aspect/pragma appears on a subprogram body, perform
+ -- the full analysis now.
- Push_Scope (Subp_Id);
- Install_Formals (Subp_Id);
+ if Nkind (Subp_Decl) = N_Subprogram_Body then
+ Analyze_Global_In_Decl_Part (N);
- Analyze_Global_List (List);
+ -- Chain the pragma on the contract for further processing
- End_Scope;
+ else
+ Add_Contract_Item (N, Subp_Id);
end if;
end Global;
git://gcc.gnu.org / gcc.git / commitdiff