-- Uint value. If the value is inappropriate, then error messages are
-- posted as required, and a value of No_Uint is returned.
- function Get_Cursor_Type (S : Entity_Id) return Entity_Id;
- -- Find Cursor type by name in the scope of an iterable type, for use in
- -- resolving the primitive operations of the type.
+ function Get_Cursor_Type
+ (Aspect : Node_Id;
+ Typ : Entity_Id) return Entity_Id;
+ -- Find Cursor type in scope of Typ, by locating primitive operation First.
+ -- For use in resolving the other primitive operations of an Iterable type.
function Is_Operational_Item (N : Node_Id) return Boolean;
-- A specification for a stream attribute is allowed before the full type
T := Entity (ASN);
declare
- Cursor : constant Entity_Id := Get_Cursor_Type (Scope (T));
+ Cursor : constant Entity_Id := Get_Cursor_Type (ASN, T);
Assoc : Node_Id;
Expr : Node_Id;
+
begin
+ if Cursor = Any_Type then
+ return;
+ end if;
+
Assoc := First (Component_Associations (Expression (ASN)));
while Present (Assoc) loop
Expr := Expression (Assoc);
Analyze (Expr);
- Resolve_Iterable_Operation
- (Expr, Cursor, T, Chars (First (Choices (Assoc))));
+
+ if not Error_Posted (Expr) then
+ Resolve_Iterable_Operation
+ (Expr, Cursor, T, Chars (First (Choices (Assoc))));
+ end if;
+
Next (Assoc);
end loop;
end;
-- Get_Cursor_Type --
---------------------
- function Get_Cursor_Type (S : Entity_Id) return Entity_Id is
- C : Entity_Id;
- E : Entity_Id;
+ function Get_Cursor_Type
+ (Aspect : Node_Id;
+ Typ : Entity_Id) return Entity_Id
+ is
+ Assoc : Node_Id;
+ Func : Entity_Id;
+ First_Op : Entity_Id;
+ Cursor : Entity_Id;
begin
- -- There must be a cursor type declared in the same package, to be
- -- used in iterable primitives.
-
- C := Empty;
- E := First_Entity (S);
- while Present (E) loop
- if Chars (E) = Name_Cursor and then Is_Type (E) then
- C := E;
+ -- If error already detected, return.
+
+ if Error_Posted (Aspect) then
+ return Any_Type;
+ end if;
+
+ -- The cursor type for an Iterable aspect is the return type of
+ -- a non-overloaded First primitive operation. Locate association
+ -- for First.
+
+ Assoc := First (Component_Associations (Expression (Aspect)));
+ First_Op := Any_Id;
+ while Present (Assoc) loop
+ if Chars (First (Choices (Assoc))) = Name_First then
+ First_Op := Expression (Assoc);
exit;
end if;
- Next_Entity (E);
+ Next (Assoc);
+ end loop;
+
+ if First_Op = Any_Id then
+ Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
+ return Any_Type;
+ end if;
+
+ Cursor := Any_Type;
+
+ -- Locate function with desired name and profile in scope of type.
+
+ Func := First_Entity (Scope (Typ));
+ while Present (Func) loop
+ if Chars (Func) = Chars (First_Op)
+ and then Ekind (Func) = E_Function
+ and then Present (First_Formal (Func))
+ and then Etype (First_Formal (Func)) = Typ
+ and then No (Next_Formal (First_Formal (Func)))
+ then
+ if Cursor /= Any_Type then
+ Error_Msg_N
+ ("Operation First for iterable type must be unique", Aspect);
+ return Any_Type;
+
+ else
+ Cursor := Etype (Func);
+ end if;
+ end if;
+
+ Next_Entity (Func);
end loop;
- return C;
+ -- If not found, no way to resolve remaining primitives.
+
+ if Cursor = Any_Type then
+ Error_Msg_N
+ ("No legal primitive operation First for Iterable type", Aspect);
+ end if;
+
+ return Cursor;
end Get_Cursor_Type;
-------------------------------------
then
Error_Msg_N ("iterable primitive must be local function name "
& "whose first formal is an iterable type", N);
+ return;
end if;
Ent := Entity (N);
Expr : Node_Id;
Prim : Node_Id;
- Cursor : constant Entity_Id := Get_Cursor_Type (Scope (Typ));
+ Cursor : constant Entity_Id := Get_Cursor_Type (ASN, Typ);
First_Id : Entity_Id;
Next_Id : Entity_Id;
Element_Id : Entity_Id;
begin
- if No (Cursor) then
- Error_Msg_N ("Iterable aspect requires a cursor type", ASN);
+ -- If previous error aspect is unusable.
+
+ if Cursor = Any_Type then
return;
end if;
-- pragma Attach_Handler.
procedure Check_Loop_Pragma_Placement;
- -- Verify whether pragma Loop_Invariant or Loop_Optimize or Loop_Variant
+ -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
-- appear immediately within a construct restricted to loops, and that
- -- pragmas Loop_Invariant and Loop_Variant applying to the same loop all
- -- appear grouped in the same sequence of statements.
+ -- pragmas Loop_Invariant and Loop_Variant are grouped together.
procedure Check_Is_In_Decl_Part_Or_Package_Spec;
-- Check that pragma appears in a declarative part, or in a package
---------------------------------
procedure Check_Loop_Pragma_Placement is
+ procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
+ -- Verify whether the current pragma is properly grouped with other
+ -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
+ -- related loop where the pragma appears.
+
+ function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
+ -- Determine whether an arbitrary statement Stmt denotes pragma
+ -- Loop_Invariant or Loop_Variant.
+
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.
- function Prev_In_Loop (Stmt : Node_Id) return Node_Id;
- -- Returns the statement or declaration preceding Stmt in the
- -- same loop, or Empty if the head of the loop is reached. Block
- -- statements are entered during this traversal.
+ --------------------------------
+ -- Check_Loop_Pragma_Grouping --
+ --------------------------------
- ---------------------
- -- Placement_Error --
- ---------------------
+ procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
+ Stop_Search : exception;
+ -- This exception is used to terminate the recursive descent of
+ -- routine Check_Grouping.
- procedure Placement_Error (Constr : Node_Id) is
- LA : constant String := " with Loop_Entry";
- begin
- if Prag_Id = Pragma_Assert then
- Error_Msg_String (1 .. LA'Length) := LA;
- Error_Msg_Strlen := LA'Length;
- else
- Error_Msg_Strlen := 0;
- end if;
+ procedure Check_Grouping (L : List_Id);
+ -- Find the first group of pragmas in list L and if successful,
+ -- ensure that the current pragma is part of that group. The
+ -- routine raises Stop_Search once such a check is performed to
+ -- halt the recursive descent.
- 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;
+ procedure Grouping_Error (Prag : Node_Id);
+ pragma No_Return (Grouping_Error);
+ -- Emit an error concerning the current pragma indicating that it
+ -- should be placed after pragma Prag.
- ------------------
- -- Prev_In_Loop --
- ------------------
+ --------------------
+ -- Check_Grouping --
+ --------------------
- function Prev_In_Loop (Stmt : Node_Id) return Node_Id is
- Prev : Node_Id;
- Reach_Inside_Blocks : Boolean;
+ procedure Check_Grouping (L : List_Id) is
+ HSS : Node_Id;
+ Prag : Node_Id;
+ Stmt : Node_Id;
- begin
- Reach_Inside_Blocks := True;
+ begin
+ -- Inspect the list of declarations or statements looking for
+ -- the first grouping of pragmas:
- -- Try the previous statement in the same list
+ -- loop
+ -- pragma Loop_Invariant ...;
+ -- pragma Loop_Variant ...;
+ -- . . . -- (1)
+ -- pragma Loop_Variant ...; -- current pragma
- Prev := Nlists.Prev (Stmt);
+ -- If the current pragma is not in the grouping, then it must
+ -- either appear in a different declarative or statement list
+ -- or the construct at (1) is separating the pragma from the
+ -- grouping.
- -- Otherwise reach to the previous statement through the parent
+ Stmt := First (L);
+ while Present (Stmt) loop
- if No (Prev) then
+ -- Pragmas Loop_Invariant and Loop_Variant may only appear
+ -- inside a loop or a block housed inside a loop. Inspect
+ -- the declarations and statements of the block as they may
+ -- contain the first grouping.
- -- If we're inside the statements of a block which contains
- -- declarations, continue with the last declaration of the
- -- block if any.
+ if Nkind (Stmt) = N_Block_Statement then
+ HSS := Handled_Statement_Sequence (Stmt);
- if Nkind (Parent (Stmt)) = N_Handled_Sequence_Of_Statements
- and then Nkind (Parent (Parent (Stmt))) = N_Block_Statement
- and then Present (Declarations (Parent (Parent (Stmt))))
- then
- Prev := Last (Declarations (Parent (Parent (Stmt))));
+ Check_Grouping (Declarations (Stmt));
- -- Ignore a handled statement sequence
+ if Present (HSS) then
+ Check_Grouping (Statements (HSS));
+ end if;
- elsif
- Nkind (Parent (Stmt)) = N_Handled_Sequence_Of_Statements
- then
- Reach_Inside_Blocks := False;
- Prev := Parent (Parent (Stmt));
+ -- The first pragma of the first topmost grouping has been
+ -- found.
- -- Do not reach past the head of the current loop
+ elsif Is_Loop_Pragma (Stmt) then
- elsif Nkind (Parent (Stmt)) = N_Loop_Statement then
- null;
+ -- The group and the current pragma are not in the same
+ -- declarative or statement list.
- -- Otherwise use the parent statement
+ if List_Containing (Stmt) /= List_Containing (N) then
+ Grouping_Error (Stmt);
- else
- Reach_Inside_Blocks := False;
- Prev := Parent (Stmt);
- end if;
- end if;
+ -- Try to reach the current pragma from the first pragma
+ -- of the grouping while skipping other members:
- -- Skip block statements
+ -- pragma Loop_Invariant ...; -- first pragma
+ -- pragma Loop_Variant ...; -- member
+ -- . . .
+ -- pragma Loop_Variant ...; -- current pragma
- while Nkind (Prev) = N_Block_Statement loop
+ else
+ while Present (Stmt) loop
- -- If a block is reached from statements that follow it, then
- -- we should reach inside the block to its last contained
- -- statement.
+ -- The current pragma is either the first pragma
+ -- of the group or is a member of the group. Stop
+ -- the search as the placement is legal.
- if Reach_Inside_Blocks then
- Prev :=
- Last (Statements (Handled_Statement_Sequence (Prev)));
+ if Stmt = N then
+ raise Stop_Search;
- -- If a block is reached from statements and declarations
- -- inside it, continue with the statements preceding the
- -- block if any.
+ -- Skip group members, but keep track of the last
+ -- pragma in the group.
- elsif Present (Nlists.Prev (Prev)) then
- Reach_Inside_Blocks := True;
- Prev := Nlists.Prev (Prev);
+ elsif Is_Loop_Pragma (Stmt) then
+ Prag := Stmt;
- -- Ignore a handled statement sequence
+ -- A non-pragma is separating the group from the
+ -- current pragma, the placement is erroneous.
- elsif
- Nkind (Parent (Prev)) = N_Handled_Sequence_Of_Statements
- then
- Prev := Parent (Parent (Prev));
+ else
+ Grouping_Error (Prag);
+ end if;
- -- Do not reach past the head of the current loop
+ Next (Stmt);
+ end loop;
- elsif Nkind (Parent (Prev)) = N_Loop_Statement then
- Prev := Empty;
+ -- If the traversal did not reach the current pragma,
+ -- then the list must be malformed.
- -- Otherwise use the parent statement
+ raise Program_Error;
+ end if;
+ end if;
- else
- Prev := Parent (Prev);
- end if;
- end loop;
+ Next (Stmt);
+ end loop;
+ end Check_Grouping;
+
+ --------------------
+ -- Grouping_Error --
+ --------------------
+
+ procedure Grouping_Error (Prag : Node_Id) is
+ begin
+ Error_Msg_Sloc := Sloc (Prag);
+ Error_Pragma ("pragma% must appear immediately after pragma#");
+ end Grouping_Error;
+
+ -- Start of processing for Check_Loop_Pragma_Grouping
+
+ begin
+ -- Inspect the statements of the loop or nested blocks housed
+ -- within to determine whether the current pragma is part of the
+ -- first topmost grouping of Loop_Invariant and Loop_Variant.
+
+ Check_Grouping (Statements (Loop_Stmt));
- return Prev;
- end Prev_In_Loop;
+ exception
+ when Stop_Search => null;
+ end Check_Loop_Pragma_Grouping;
+
+ --------------------
+ -- Is_Loop_Pragma --
+ --------------------
+
+ function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
+ begin
+ -- Inspect the original node as Loop_Invariant and Loop_Variant
+ -- pragmas are rewritten to null when assertions are disabled.
+
+ if Nkind (Original_Node (Stmt)) = N_Pragma then
+ return
+ Nam_In (Pragma_Name (Original_Node (Stmt)),
+ Name_Loop_Invariant,
+ Name_Loop_Variant);
+ else
+ return False;
+ end if;
+ end Is_Loop_Pragma;
+
+ ---------------------
+ -- Placement_Error --
+ ---------------------
+
+ procedure Placement_Error (Constr : Node_Id) is
+ LA : constant String := " with Loop_Entry";
+ begin
+ if Prag_Id = Pragma_Assert then
+ Error_Msg_String (1 .. LA'Length) := LA;
+ Error_Msg_Strlen := LA'Length;
+ else
+ Error_Msg_Strlen := 0;
+ end if;
+
+ 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;
- Orig_Stmt : Node_Id;
- Within_Same_Sequence : Boolean;
+ Prev : Node_Id;
+ Stmt : Node_Id;
-- Start of processing for Check_Loop_Pragma_Placement
end if;
end loop;
- -- For a Loop_Invariant or Loop_Variant pragma, check that previous
- -- Loop_Invariant and Loop_Variant pragmas for the same loop appear
- -- in the same sequence of statements, with only intervening similar
- -- pragmas.
-
- if Prag_Id = Pragma_Loop_Invariant
- or else
- Prag_Id = Pragma_Loop_Variant
- then
- Stmt := Prev_In_Loop (N);
- Within_Same_Sequence := True;
-
- while Present (Stmt) loop
-
- -- The pragma may have been rewritten as a null statement if
- -- assertions are not enabled, in which case the original node
- -- should be used.
-
- Orig_Stmt := Original_Node (Stmt);
+ -- Check that the current pragma Loop_Invariant or Loop_Variant is
+ -- grouped together with other such pragmas.
- -- Issue an error on a non-consecutive Loop_Invariant or
- -- Loop_Variant pragma.
+ if Is_Loop_Pragma (N) then
- if Nkind (Orig_Stmt) = N_Pragma then
- declare
- Stmt_Prag_Id : constant Pragma_Id :=
- Get_Pragma_Id (Pragma_Name (Orig_Stmt));
+ -- The previous check should have located the related loop
- begin
- if Stmt_Prag_Id = Pragma_Loop_Invariant
- or else
- Stmt_Prag_Id = Pragma_Loop_Variant
- then
- if List_Containing (Stmt) /= List_Containing (N)
- or else not Within_Same_Sequence
- then
- Error_Msg_Sloc := Sloc (Orig_Stmt);
- Error_Pragma
- ("pragma% must appear immediately after pragma#");
-
- -- Continue searching for previous Loop_Invariant and
- -- Loop_Variant pragmas even after finding a previous
- -- correct pragma, so that an error is also issued
- -- for the current pragma in case there is a previous
- -- non-consecutive pragma.
-
- else
- null;
- end if;
-
- -- Mark the end of the consecutive sequence of pragmas
-
- else
- Within_Same_Sequence := False;
- end if;
- end;
-
- -- Mark the end of the consecutive sequence of pragmas
-
- else
- Within_Same_Sequence := False;
- end if;
-
- Stmt := Prev_In_Loop (Stmt);
- end loop;
+ pragma Assert (Nkind (Stmt) = N_Loop_Statement);
+ Check_Loop_Pragma_Grouping (Stmt);
end if;
end Check_Loop_Pragma_Placement;
projects / thirdparty / gcc.git / commitdiff
