-- others_choice is static if the corresponding expression is static.
-- The staticness of the bounds is checked separately.
+ procedure Analyze_User_Aspect_Aspect_Specification (N : Node_Id);
+ -- Analyze a User_Aspect aspect specification. Called from outside
+ -- this package (in addition to locally), but the call from aspect.adb
+ -- is via an access-to-subprogram value.
+
procedure Build_Discrete_Static_Predicate
(Typ : Entity_Id;
Expr : Node_Id;
-- containers.
procedure Resolve_Aspect_Aggregate
- (Typ : Entity_Id;
- Expr : Node_Id);
+ (Typ : Entity_Id;
+ Expr : Node_Id);
-- Resolve each one of the operations specified in the specification of
-- Aspect_Aggregate.
+ procedure Validate_Aspect_Local_Restrictions (E : Entity_Id; N : Node_Id);
+ -- Check legality of a Local_Restrictions aspect specification
+
procedure Validate_Aspect_Stable_Properties
(E : Entity_Id; N : Node_Id; Class_Present : Boolean);
-- Check legality of functions given in the Ada 2022 Stable_Properties
-- Mark aspect analyzed (actual analysis is delayed till later)
- Set_Analyzed (Aspect);
+ if A_Id /= Aspect_User_Aspect then
+ -- Analyzed flag is handled differently for a User_Aspect
+ -- aspect specification because it can also be analyzed
+ -- "on demand" from Aspects.Find_Aspect. So that analysis
+ -- tests for the case where the aspect specification has
+ -- already been analyzed (in which case it just returns)
+ -- and takes care of calling Set_Analyzed.
+
+ Set_Analyzed (Aspect);
+ end if;
+
Set_Entity (Aspect, E);
-- Build the reference to E that will be used in the built pragmas
Insert_Pragma (Aitem);
goto Continue;
+ -- User_Aspect
+
+ when Aspect_User_Aspect =>
+ Analyze_User_Aspect_Aspect_Specification (Aspect);
+ goto Continue;
+
-- Volatile_Function
-- Aspect Volatile_Function is never delayed because it is
Record_Rep_Item (E, Aspect);
goto Continue;
+ when Aspect_Local_Restrictions =>
+ Validate_Aspect_Local_Restrictions (E, Expr);
+ Record_Rep_Item (E, Aspect);
+ goto Continue;
+
when Aspect_Stable_Properties =>
Validate_Aspect_Stable_Properties
(E, Expr, Class_Present => Class_Present (Aspect));
end if;
end Analyze_Record_Representation_Clause;
+ ----------------------------------------------
+ -- Analyze_User_Aspect_Aspect_Specification --
+ ----------------------------------------------
+
+ procedure Analyze_User_Aspect_Aspect_Specification (N : Node_Id) is
+ OK : Boolean := True;
+
+ procedure Analyze_One_User_Aspect (Id : Node_Id);
+ -- A User_Aspect aspect specification may specify multiple
+ -- user-defined aspects. This procedure is called for each one.
+
+ -----------------------------
+ -- Analyze_One_User_Aspect --
+ -----------------------------
+
+ procedure Analyze_One_User_Aspect (Id : Node_Id) is
+ UAD_Pragma : constant Node_Id :=
+ User_Aspect_Support.Registered_UAD_Pragma (Chars (Id));
+
+ Arg : Node_Id;
+ begin
+ if No (UAD_Pragma) then
+ Error_Msg_N ("No definition for user-defined aspect", Id);
+ return;
+ end if;
+
+ -- Process args in reverse order so that inserted
+ -- aspect specs end up in "right" order (although
+ -- order shouldn't matter).
+ Arg := Last (Pragma_Argument_Associations (UAD_Pragma));
+
+ -- Skip first argument, which is the name of the
+ -- user-defined aspect.
+ while Present (Prev (Arg)) loop
+ declare
+ Exp : constant Node_Id := Expression (Arg);
+ New_Sloc : constant Source_Ptr := Sloc (N);
+ New_Aspect_Spec : Node_Id;
+ New_Exp : Node_Id;
+ New_Exp_List : List_Id;
+ begin
+ case Nkind (Exp) is
+ when N_Identifier =>
+ New_Aspect_Spec :=
+ Make_Aspect_Specification
+ (New_Sloc,
+ Identifier =>
+ New_Copy_Tree (Exp, New_Sloc => New_Sloc));
+
+ when N_Indexed_Component =>
+ New_Exp_List := New_List;
+
+ declare
+ Index_Exp : Node_Id := First (Expressions (Exp));
+ begin
+ while Present (Index_Exp) loop
+ Append (New_Copy_Tree
+ (Index_Exp, New_Sloc => New_Sloc),
+ To => New_Exp_List);
+ Next (Index_Exp);
+ end loop;
+ end;
+
+ New_Exp := Make_Aggregate
+ (Sloc => New_Sloc,
+ Expressions => New_Exp_List,
+ Is_Parenthesis_Aggregate => True);
+
+ New_Aspect_Spec :=
+ Make_Aspect_Specification
+ (New_Sloc,
+ Identifier =>
+ New_Copy_Tree (Prefix (Exp), New_Sloc => New_Sloc),
+ Expression => New_Exp);
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ Insert_After (After => N, Node => New_Aspect_Spec);
+ end;
+ Arg := Prev (Arg);
+ end loop;
+ end Analyze_One_User_Aspect;
+ begin
+ if Analyzed (N) then
+ return;
+ end if;
+
+ -- This aspect can be specified for any entity whose
+ -- syntax allows an aspect specification.
+ -- The analysis code below constructs new aspect
+ -- specifications for the given entity; each might
+ -- turn out to be legal or illegal. That is determined
+ -- when each of these new aspect_specs is analyzed.
+
+ case Nkind (Expression (N)) is
+ when N_Identifier =>
+ Analyze_One_User_Aspect (Expression (N));
+ when N_Aggregate =>
+ OK := Is_Parenthesis_Aggregate (Expression (N));
+ declare
+ Id : Node_Id := First (Expressions (Expression (N)));
+ begin
+ while Present (Id) loop
+ if Nkind (Id) = N_Identifier then
+ Analyze_One_User_Aspect (Id);
+ else
+ OK := False;
+ end if;
+ Next (Id);
+ end loop;
+ end;
+ when others =>
+ OK := False;
+ end case;
+
+ if not OK then
+ Error_Msg_N
+ ("Bad argument for User_Aspect aspect specification", N);
+ end if;
+
+ Set_Analyzed (N);
+ end Analyze_User_Aspect_Aspect_Specification;
+
-------------------------------------
-- Build_Discrete_Static_Predicate --
-------------------------------------
when Aspect_Linker_Section =>
T := Standard_String;
+ when Aspect_Local_Restrictions =>
+ return;
+
when Aspect_Synchronization =>
return;
| Aspect_Test_Case
| Aspect_Unimplemented
| Aspect_Unsuppress
+ | Aspect_User_Aspect
| Aspect_Volatile_Function
=>
raise Program_Error;
Resolve_Aspect_Stable_Properties
(Entity (ASN), Expr, Class_Present (ASN));
+ when Aspect_Local_Restrictions =>
+ -- Expression is an aggregate, but only syntactically
+ null;
+
-- For now we only deal with aspects that do not generate
-- subprograms, or that may mention current instances of
-- types. These will require special handling???.
end loop;
end Parse_Aspect_Aggregate;
+ -------------------------------------
+ -- Parse_Aspect_Local_Restrictions --
+ -------------------------------------
+
+ function Parse_Aspect_Local_Restrictions (Aspect_Spec : Node_Id)
+ return Local_Restrict.Local_Restriction_Set
+ is
+ use Local_Restrict;
+
+ Result : Local_Restriction_Set := (others => False);
+ Id : Node_Id := Expression (Aspect_Spec);
+ Is_Agg : constant Boolean := Nkind (Id) = N_Aggregate
+ and then not Is_Empty_List (Expressions (Id));
+ begin
+ if Is_Agg then
+ Id := First (Expressions (Id));
+ end if;
+
+ while Present (Id) loop
+ if Nkind (Id) /= N_Identifier then
+ Error_Msg_N ("local restriction name not an identifier", Id);
+ exit;
+ end if;
+
+ declare
+ Found : Boolean := False;
+ Nam : constant Name_Id := Chars (Id);
+ begin
+ for L_R in Local_Restriction loop
+ declare
+ S : String := L_R'Img;
+ begin
+ -- Note that the instance of System.Case_Util.To_Lower that
+ -- has signature
+ --
+ -- function To_Lower (A : String) return String
+ --
+ -- cannot be used here because it is not present in the
+ -- run-time library used by the bootstrap compiler at the
+ -- time of writing.
+ To_Lower (S);
+ if Length_Of_Name (Nam) = S'Length
+ and then Get_Name_String (Nam) = S
+ then
+ if Result (L_R) then
+ Error_Msg_N ("local restriction duplicated", Id);
+ exit;
+ end if;
+ Found := True;
+ Result (L_R) := True;
+ exit;
+ end if;
+ end;
+ end loop;
+
+ if not Found then
+ Error_Msg_N ("invalid local restriction name", Id);
+ exit;
+ end if;
+ end;
+
+ exit when not Is_Agg;
+ Next (Id);
+ end loop;
+
+ return Result;
+ end Parse_Aspect_Local_Restrictions;
+
------------------------------------
-- Parse_Aspect_Stable_Properties --
------------------------------------
end if;
end Validate_Aspect_Aggregate;
- -------------------------------
+ -----------------------------------------
+ -- Validate_Aspect_Local_Restrictions --
+ -----------------------------------------
+
+ procedure Validate_Aspect_Local_Restrictions (E : Entity_Id; N : Node_Id) is
+ use Local_Restrict;
+ begin
+ -- Do not check Is_Parenthesis_Aggregate. We don't want to
+ -- disallow the more familiar parens, but we also don't
+ -- want to require parens for a homogeneous list.
+
+ if Nkind (N) = N_Identifier and then Paren_Count (N) = 1 then
+ -- a positional aggregate with one element (in effect) is ok
+ null;
+ elsif Nkind (N) /= N_Aggregate
+ or else No (Expressions (N))
+ or else Present (Component_Associations (N))
+ then
+ Error_Msg_N
+ ("aspect Local_Restrictions requires a parenthesized list", N);
+ return;
+ end if;
+
+ declare
+ Set : constant Local_Restriction_Set
+ := Parse_Aspect_Local_Restrictions (Parent (N));
+ pragma Unreferenced (Set);
+ begin
+ null;
+ end;
+
+ -- This will be relaxed later, e.g. for generic subprograms or
+ -- for packages.
+
+ if Ekind (E) in Subprogram_Kind | E_Package then
+ if Get_Renamed_Entity (E) /= E then
+ Error_Msg_N
+ ("aspect Local_Restrictions cannot be specified for "
+ & "a renaming", N);
+ end if;
+ else
+ Error_Msg_N
+ ("aspect Local_Restrictions can only be specified for "
+ & "a subprogram or package spec", N);
+ end if;
+ end Validate_Aspect_Local_Restrictions;
+
+ ---------------------------------------
-- Validate_Aspect_Stable_Properties --
- -------------------------------
+ ---------------------------------------
procedure Validate_Aspect_Stable_Properties
(E : Entity_Id; N : Node_Id; Class_Present : Boolean)
end loop;
end Validate_Unchecked_Conversions;
+begin
+ User_Aspect_Support.Analyze_User_Aspect_Aspect_Specification_Hook :=
+ Analyze_User_Aspect_Aspect_Specification'Access;
end Sem_Ch13;
git://gcc.gnu.org / gcc.git / blobdiff