+2011-11-04 Yannick Moy <moy@adacore.com>
+
+ * atree.adb, atree.ads (Set_Original_Node): New set procedure.
+ * sem_ch13.adb (Analyze_Aspect_Specifications/Pre_Post_Aspects):
+ In ASIS mode, no splitting of aspects between conjuncts.
+ (Analyze_Aspect_Specifications/Aspect_Test_Case): Make pragma
+ expressions refer to the original aspect expressions through
+ the Original_Node link. This is used in semantic analysis for
+ ASIS mode, so that the original expression also gets analyzed.
+ * sem_prag.adb (Preanalyze_TC_Args,
+ Check_Precondition_Postcondition,
+ Analyze_Pragma/Pragma_Test_Case): In ASIS mode, for a pragma
+ generated from a source aspect, also analyze the original aspect
+ expression.
+ (Check_Expr_Is_Static_Expression): New procedure
+ similar to existing procedure Check_Arg_Is_Static_Expression,
+ except called on expression inside pragma.
+
+2011-11-04 Tristan Gingold <gingold@adacore.com>
+
+ * prj-env.adb, prj-env.ads (Find_Name_In_Path): New function, from
+ Find_Project.Try_Path_Name.
+ (Find_Project): Use Find_Name_In_Path to implement Try_Path_Name.
+
+2011-11-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * s-atocou.ads (Atomic_Counter): Remove redundant pragma Volatile.
+
+2011-11-04 Pascal Obry <obry@adacore.com>
+
+ * projects.texi: Add short description for qualifiers aggregate
+ and aggregate library.
+
+2011-11-04 Matthew Heaney <heaney@adacore.com>
+
+ * Makefile.rtl, impunit.adb: Added a-cogeso.ad[sb]
+ * a-cgaaso.adb: Replaced implementation with instantiation
+ of Generic_Sort.
+ * a-cogeso.ad[sb] This is the new Ada 2012 unit
+ Ada.Containers.Generic_Sort
+
2011-11-04 Robert Dewar <dewar@adacore.com>
* exp_ch2.adb (Expand_Entity_Reference): Do not set
a-ciormu$(objext) \
a-ciorse$(objext) \
a-clrefi$(objext) \
+ a-cogeso$(objext) \
a-cohama$(objext) \
a-cohase$(objext) \
a-cohata$(objext) \
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
--- This algorithm was adapted from GNAT.Heap_Sort (see g-heasor.ad[sb])
+-- This unit was originally a GNAT-specific addition to Ada 2005. A unit
+-- providing the same feature, Ada.Containers.Generic_Sort, was defined for
+-- Ada 2012. We retain Generic_Anonymous_Array_Sort for compatibility, but
+-- implement it in terms of the official unit, Generic_Sort.
-with System;
+with Ada.Containers.Generic_Sort;
procedure Ada.Containers.Generic_Anonymous_Array_Sort
(First, Last : Index_Type'Base)
is
- type T is range System.Min_Int .. System.Max_Int;
-
- function To_Index (J : T) return Index_Type;
- pragma Inline (To_Index);
-
- function Lt (J, K : T) return Boolean;
- pragma Inline (Lt);
-
- procedure Xchg (J, K : T);
- pragma Inline (Xchg);
-
- procedure Sift (S : T);
-
- --------------
- -- To_Index --
- --------------
-
- function To_Index (J : T) return Index_Type is
- K : constant T'Base := Index_Type'Pos (First) + J - T'(1);
- begin
- return Index_Type'Val (K);
- end To_Index;
-
- --------
- -- Lt --
- --------
-
- function Lt (J, K : T) return Boolean is
- begin
- return Less (To_Index (J), To_Index (K));
- end Lt;
-
- ----------
- -- Xchg --
- ----------
-
- procedure Xchg (J, K : T) is
- begin
- Swap (To_Index (J), To_Index (K));
- end Xchg;
-
- Max : T := Index_Type'Pos (Last) - Index_Type'Pos (First) + T'(1);
-
- ----------
- -- Sift --
- ----------
-
- procedure Sift (S : T) is
- C : T := S;
- Son : T;
- Father : T;
-
- begin
- loop
- Son := C + C;
-
- if Son < Max then
- if Lt (Son, Son + 1) then
- Son := Son + 1;
- end if;
- elsif Son > Max then
- exit;
- end if;
-
- Xchg (Son, C);
- C := Son;
- end loop;
-
- while C /= S loop
- Father := C / 2;
-
- if Lt (Father, C) then
- Xchg (Father, C);
- C := Father;
- else
- exit;
- end if;
- end loop;
- end Sift;
-
--- Start of processing for Generic_Anonymous_Array_Sort
+ procedure Sort is new Ada.Containers.Generic_Sort
+ (Index_Type => Index_Type,
+ Before => Less,
+ Swap => Swap);
begin
- for J in reverse 1 .. Max / 2 loop
- Sift (J);
- end loop;
-
- while Max > 1 loop
- Xchg (1, Max);
- Max := Max - 1;
- Sift (1);
- end loop;
+ Sort (First, Last);
end Ada.Containers.Generic_Anonymous_Array_Sort;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.GENERIC_SORT --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2011, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- This unit was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+-- This algorithm was adapted from GNAT.Heap_Sort (see g-heasor.ad[sb])
+
+with System;
+
+procedure Ada.Containers.Generic_Sort (First, Last : Index_Type'Base) is
+ type T is range System.Min_Int .. System.Max_Int;
+
+ function To_Index (J : T) return Index_Type;
+ pragma Inline (To_Index);
+
+ function Lt (J, K : T) return Boolean;
+ pragma Inline (Lt);
+
+ procedure Xchg (J, K : T);
+ pragma Inline (Xchg);
+
+ procedure Sift (S : T);
+
+ --------------
+ -- To_Index --
+ --------------
+
+ function To_Index (J : T) return Index_Type is
+ K : constant T'Base := Index_Type'Pos (First) + J - T'(1);
+ begin
+ return Index_Type'Val (K);
+ end To_Index;
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (J, K : T) return Boolean is
+ begin
+ return Before (To_Index (J), To_Index (K));
+ end Lt;
+
+ ----------
+ -- Xchg --
+ ----------
+
+ procedure Xchg (J, K : T) is
+ begin
+ Swap (To_Index (J), To_Index (K));
+ end Xchg;
+
+ Max : T := Index_Type'Pos (Last) - Index_Type'Pos (First) + T'(1);
+
+ ----------
+ -- Sift --
+ ----------
+
+ procedure Sift (S : T) is
+ C : T := S;
+ Son : T;
+ Father : T;
+
+ begin
+ loop
+ Son := C + C;
+
+ if Son < Max then
+ if Lt (Son, Son + 1) then
+ Son := Son + 1;
+ end if;
+ elsif Son > Max then
+ exit;
+ end if;
+
+ Xchg (Son, C);
+ C := Son;
+ end loop;
+
+ while C /= S loop
+ Father := C / 2;
+
+ if Lt (Father, C) then
+ Xchg (Father, C);
+ C := Father;
+ else
+ exit;
+ end if;
+ end loop;
+ end Sift;
+
+-- Start of processing for Generic_Sort
+
+begin
+ for J in reverse 1 .. Max / 2 loop
+ Sift (J);
+ end loop;
+
+ while Max > 1 loop
+ Xchg (1, Max);
+ Max := Max - 1;
+ Sift (1);
+ end loop;
+end Ada.Containers.Generic_Sort;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.GENERIC_SORT --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2011, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- This unit was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+-- Allows an anonymous array (or array-like container) to be sorted. Generic
+-- formal Before returns the result of comparing the elements designated by
+-- the indexes, and generic formal Swap exchanges the designated elements.
+
+generic
+ type Index_Type is (<>);
+ with function Before (Left, Right : Index_Type) return Boolean;
+ with procedure Swap (Left, Right : Index_Type);
+
+procedure Ada.Containers.Generic_Sort (First, Last : Index_Type'Base);
+pragma Pure (Ada.Containers.Generic_Sort);
Nodes.Table (N).Has_Aspects := Val;
end Set_Has_Aspects;
+ -----------------------
+ -- Set_Original_Node --
+ -----------------------
+
+ procedure Set_Original_Node (N : Node_Id; Val : Node_Id) is
+ begin
+ Orig_Nodes.Table (N) := Val;
+ end Set_Original_Node;
+
---------------------
-- Set_Paren_Count --
---------------------
procedure Set_Has_Aspects (N : Node_Id; Val : Boolean := True);
pragma Inline (Set_Has_Aspects);
+ procedure Set_Original_Node (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Original_Node);
+
------------------------------
-- Entity Update Procedures --
------------------------------
-- Note: strictly the following should be Ada 2012 units, but it seems
-- harmless (and useful) to make then available in Ada 2005 mode.
+ ("a-cogeso", T), -- Ada.Containers.Generic_Sort
("a-secain", T), -- Ada.Strings.Equal_Case_Insensitive
("a-shcain", T), -- Ada.Strings.Hash_Case_Insensitive
("a-slcain", T), -- Ada.Strings.Less_Case_Insensitive
Projects_Paths.Reset (Self.Cache);
end Set_Path;
+ -----------------------
+ -- Find_Name_In_Path --
+ -----------------------
+
+ function Find_Name_In_Path (Self : Project_Search_Path;
+ Path : String) return String_Access is
+ First : Natural;
+ Last : Natural;
+
+ begin
+ if Current_Verbosity = High then
+ Debug_Output ("Trying " & Path);
+ end if;
+
+ if Is_Absolute_Path (Path) then
+ if Check_Filename (Path) then
+ return new String'(Path);
+ else
+ return null;
+ end if;
+
+ else
+ -- Because we don't want to resolve symbolic links, we cannot use
+ -- Locate_Regular_File. So, we try each possible path
+ -- successively.
+
+ First := Self.Path'First;
+ while First <= Self.Path'Last loop
+ while First <= Self.Path'Last
+ and then Self.Path (First) = Path_Separator
+ loop
+ First := First + 1;
+ end loop;
+
+ exit when First > Self.Path'Last;
+
+ Last := First;
+ while Last < Self.Path'Last
+ and then Self.Path (Last + 1) /= Path_Separator
+ loop
+ Last := Last + 1;
+ end loop;
+
+ Name_Len := 0;
+
+ if not Is_Absolute_Path (Self.Path (First .. Last)) then
+ Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call
+ Add_Char_To_Name_Buffer (Directory_Separator);
+ end if;
+
+ Add_Str_To_Name_Buffer (Self.Path (First .. Last));
+ Add_Char_To_Name_Buffer (Directory_Separator);
+ Add_Str_To_Name_Buffer (Path);
+
+ if Current_Verbosity = High then
+ Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len));
+ end if;
+
+ if Check_Filename (Name_Buffer (1 .. Name_Len)) then
+ return new String'(Name_Buffer (1 .. Name_Len));
+ end if;
+
+ First := Last + 1;
+ end loop;
+ end if;
+
+ return null;
+ end Find_Name_In_Path;
+
------------------
-- Find_Project --
------------------
-- Have to do a copy, in case the parameter is Name_Buffer, which we
-- modify below
- function Try_Path_Name (Path : String) return String_Access;
- pragma Inline (Try_Path_Name);
- -- Try the specified Path
-
- -------------------
- -- Try_Path_Name --
- -------------------
-
- function Try_Path_Name (Path : String) return String_Access is
- First : Natural;
- Last : Natural;
- Result : String_Access := null;
-
- begin
- if Current_Verbosity = High then
- Debug_Output ("Trying " & Path);
- end if;
-
- if Is_Absolute_Path (Path) then
- if Is_Regular_File (Path) then
- Result := new String'(Path);
- end if;
-
- else
- -- Because we don't want to resolve symbolic links, we cannot use
- -- Locate_Regular_File. So, we try each possible path
- -- successively.
-
- First := Self.Path'First;
- while First <= Self.Path'Last loop
- while First <= Self.Path'Last
- and then Self.Path (First) = Path_Separator
- loop
- First := First + 1;
- end loop;
-
- exit when First > Self.Path'Last;
-
- Last := First;
- while Last < Self.Path'Last
- and then Self.Path (Last + 1) /= Path_Separator
- loop
- Last := Last + 1;
- end loop;
-
- Name_Len := 0;
-
- if not Is_Absolute_Path (Self.Path (First .. Last)) then
- Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call
- Add_Char_To_Name_Buffer (Directory_Separator);
- end if;
-
- Add_Str_To_Name_Buffer (Self.Path (First .. Last));
- Add_Char_To_Name_Buffer (Directory_Separator);
- Add_Str_To_Name_Buffer (Path);
-
- if Current_Verbosity = High then
- Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len));
- end if;
-
- if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
- Result := new String'(Name_Buffer (1 .. Name_Len));
- exit;
- end if;
-
- First := Last + 1;
- end loop;
- end if;
-
- return Result;
- end Try_Path_Name;
+ function Try_Path_Name is new Find_Name_In_Path
+ (Check_Filename => Is_Regular_File);
+ -- Find a file in the project search path.
-- Local Declarations
if not Has_Dot then
Result := Try_Path_Name
- (Directory & Directory_Separator &
+ (Self,
+ Directory & Directory_Separator &
File & Project_File_Extension);
end if;
-- Then we try <directory>/<file_name>
if Result = null then
- Result := Try_Path_Name (Directory & Directory_Separator & File);
+ Result := Try_Path_Name
+ (Self,
+ Directory & Directory_Separator & File);
end if;
end if;
-- Then we try <file_name>.<extension>
if Result = null and then not Has_Dot then
- Result := Try_Path_Name (File & Project_File_Extension);
+ Result := Try_Path_Name (Self, File & Project_File_Extension);
end if;
-- Then we try <file_name>
if Result = null then
- Result := Try_Path_Name (File);
+ Result := Try_Path_Name (Self, File);
end if;
-- If we cannot find the project file, we return an empty string
-- Override the value of the project path. This also removes the implicit
-- default search directories.
+ generic
+ with function Check_Filename (Name : String) return Boolean;
+ function Find_Name_In_Path (Self : Project_Search_Path;
+ Path : String) return String_Access;
+ -- Find a name in the project search path of Self. Check_Filename is
+ -- the predicate to valid the search. If Path is an absolute filename,
+ -- simply calls the predicate with Path. Otherwise, calls the predicate
+ -- for each component of the path. Stops as soon as the predicate
+ -- returns True and returns the name, or returns null in case of failure.
+
procedure Find_Project
(Self : in out Project_Search_Path;
Project_File_Name : String;
qualified abstract project.
@item @b{standard}: a standard project is a non library project with sources.
This is the default (implicit) qualifier.
-@item @b{aggregate}: for future extension
-@item @b{aggregate library}: for future extension
+@item @b{aggregate}: a project whose sources are aggregated from other
+project files.
+@item @b{aggregate library}: a library whose sources are aggregated
+from other project or library project files.
@item @b{library}: a library project must declare both attributes
@code{Library_Name} and @code{Library_Dir}.
@item @b{configuration}: a configuration project cannot be in a project tree.
type Atomic_Counter is limited record
Value : aliased Unsigned_32 := 1;
pragma Atomic (Value);
- pragma Volatile (Value);
end record;
end System.Atomic_Counters;
-- We do not do this for Pre'Class, since we have to put
-- these conditions together in a complex OR expression
- if Pname = Name_Postcondition
- or else not Class_Present (Aspect)
+ -- We do not do this in ASIS mode, as ASIS relies on the
+ -- original node representing the complete expression, when
+ -- retrieving it through the source aspect table.
+
+ if not ASIS_Mode
+ and then (Pname = Name_Postcondition
+ or else not Class_Present (Aspect))
then
while Nkind (Expr) = N_And_Then loop
Insert_After (Aspect,
Args : List_Id;
Comp_Expr : Node_Id;
Comp_Assn : Node_Id;
+ New_Expr : Node_Id;
begin
Args := New_List;
goto Continue;
end if;
+ -- Make pragma expressions refer to the original aspect
+ -- expressions through the Original_Node link. This is used
+ -- in semantic analysis for ASIS mode, so that the original
+ -- expression also gets analyzed.
+
Comp_Expr := First (Expressions (Expr));
while Present (Comp_Expr) loop
+ New_Expr := Relocate_Node (Comp_Expr);
+ Set_Original_Node (New_Expr, Comp_Expr);
Append
(Make_Pragma_Argument_Association (Sloc (Comp_Expr),
- Expression => Relocate_Node (Comp_Expr)),
+ Expression => New_Expr),
Args);
Next (Comp_Expr);
end loop;
goto Continue;
end if;
+ New_Expr := Relocate_Node (Expression (Comp_Assn));
+ Set_Original_Node (New_Expr, Expression (Comp_Assn));
Append (Make_Pragma_Argument_Association (
Sloc => Sloc (Comp_Assn),
Chars => Chars (First (Choices (Comp_Assn))),
- Expression => Relocate_Node (Expression (Comp_Assn))),
+ Expression => New_Expr),
Args);
Next (Comp_Assn);
end loop;
Source : constant Entity_Id := T.Source;
Target : constant Entity_Id := T.Target;
- Source_Siz : Uint;
- Target_Siz : Uint;
+ Source_Siz : Uint;
+ Target_Siz : Uint;
begin
-- This validation check, which warns if we have unequal sizes for
-- original one, following the renaming chain) is returned. Otherwise the
-- entity is returned unchanged. Should be in Einfo???
- procedure Preanalyze_TC_Args (Arg_Req, Arg_Ens : Node_Id);
+ procedure Preanalyze_TC_Args (N, Arg_Req, Arg_Ens : Node_Id);
-- Preanalyze the boolean expressions in the Requires and Ensures arguments
-- of a Test_Case pragma if present (possibly Empty). We treat these as
-- spec expressions (i.e. similar to a default expression).
-- Preanalyze the boolean expression, we treat this as a spec expression
-- (i.e. similar to a default expression).
- Preanalyze_Spec_Expression
- (Get_Pragma_Arg (Arg1), Standard_Boolean);
+ Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean);
+
+ -- In ASIS mode, for a pragma generated from a source aspect, also
+ -- analyze the original aspect expression.
+
+ if ASIS_Mode
+ and then Present (Corresponding_Aspect (N))
+ then
+ Preanalyze_Spec_Expression
+ (Expression (Corresponding_Aspect (N)), Standard_Boolean);
+ end if;
-- 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)
-- This procedure checks for possible duplications if this is the export
-- case, and if found, issues an appropriate error message.
+ procedure Check_Expr_Is_Static_Expression
+ (Argx : Node_Id;
+ Typ : Entity_Id := Empty);
+ -- Check the specified expression Argx 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.
+
procedure Check_First_Subtype (Arg : Node_Id);
-- Checks that Arg, whose expression is an entity name, references a
-- first subtype.
procedure Check_Arg_Is_Static_Expression
(Arg : Node_Id;
- Typ : Entity_Id := Empty)
- is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
-
+ Typ : Entity_Id := Empty) is
begin
- if Present (Typ) then
- Analyze_And_Resolve (Argx, Typ);
- else
- Analyze_And_Resolve (Argx);
- end if;
-
- if Is_OK_Static_Expression (Argx) then
- return;
-
- elsif Etype (Argx) = Any_Type then
- raise Pragma_Exit;
-
- -- 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 (Argx) = N_String_Literal
- then
- return;
-
- -- Static expression that raises Constraint_Error. This has already
- -- been flagged, so just exit from pragma processing.
-
- elsif Is_Static_Expression (Argx) 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, Argx);
- end;
-
- raise Pragma_Exit;
- end if;
+ Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ);
end Check_Arg_Is_Static_Expression;
------------------------------------------
end if;
end Check_Duplicated_Export_Name;
+ -------------------------------------
+ -- Check_Expr_Is_Static_Expression --
+ -------------------------------------
+
+ procedure Check_Expr_Is_Static_Expression
+ (Argx : Node_Id;
+ Typ : Entity_Id := Empty) is
+ begin
+ if Present (Typ) then
+ Analyze_And_Resolve (Argx, Typ);
+ else
+ Analyze_And_Resolve (Argx);
+ end if;
+
+ if Is_OK_Static_Expression (Argx) then
+ return;
+
+ elsif Etype (Argx) = Any_Type then
+ raise Pragma_Exit;
+
+ -- 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 (Argx) = N_String_Literal
+ then
+ return;
+
+ -- Static expression that raises Constraint_Error. This has already
+ -- been flagged, so just exit from pragma processing.
+
+ elsif Is_Static_Expression (Argx) 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, Argx);
+ end;
+
+ raise Pragma_Exit;
+ end if;
+ end Check_Expr_Is_Static_Expression;
+
-------------------------
-- Check_First_Subtype --
-------------------------
Preanalyze_Spec_Expression
(Get_Pragma_Arg (Arg1), Standard_Boolean);
+
+ -- In ASIS mode, for a pragma generated from a source aspect,
+ -- also analyze the original aspect expression.
+
+ if ASIS_Mode
+ and then Present (Corresponding_Aspect (N))
+ then
+ Preanalyze_Spec_Expression
+ (Expression (Corresponding_Aspect (N)), Standard_Boolean);
+ end if;
end if;
In_Body := True;
Check_Optional_Identifier (Arg1, Name_Name);
Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+
+ -- In ASIS mode, for a pragma generated from a source aspect, also
+ -- analyze the original aspect expression.
+
+ 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;
+
Check_Optional_Identifier (Arg2, Name_Mode);
Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
-- Preanalyze the boolean expressions, we treat these as spec
-- expressions (i.e. similar to a default expression).
- Preanalyze_TC_Args (Get_Requires_From_Test_Case_Pragma (N),
+ Preanalyze_TC_Args (N,
+ Get_Requires_From_Test_Case_Pragma (N),
Get_Ensures_From_Test_Case_Pragma (N));
-- Remove the subprogram from the scope stack now that the pre-analysis
-- Preanalyze_TC_Args --
------------------------
- procedure Preanalyze_TC_Args (Arg_Req, Arg_Ens : Node_Id) is
+ procedure Preanalyze_TC_Args (N, Arg_Req, Arg_Ens : Node_Id) is
begin
-- Preanalyze the boolean expressions, we treat these as spec
-- expressions (i.e. similar to a default expression).
if Present (Arg_Req) then
+
Preanalyze_Spec_Expression
(Get_Pragma_Arg (Arg_Req), Standard_Boolean);
+
+ -- In ASIS mode, for a pragma generated from a source aspect, also
+ -- analyze the original aspect expression.
+
+ if ASIS_Mode
+ and then Present (Corresponding_Aspect (N))
+ then
+ Preanalyze_Spec_Expression
+ (Original_Node (Get_Pragma_Arg (Arg_Req)), Standard_Boolean);
+ end if;
end if;
if Present (Arg_Ens) then
+
Preanalyze_Spec_Expression
(Get_Pragma_Arg (Arg_Ens), Standard_Boolean);
+
+ -- In ASIS mode, for a pragma generated from a source aspect, also
+ -- analyze the original aspect expression.
+
+ if ASIS_Mode
+ and then Present (Corresponding_Aspect (N))
+ then
+ Preanalyze_Spec_Expression
+ (Original_Node (Get_Pragma_Arg (Arg_Ens)), Standard_Boolean);
+ end if;
end if;
end Preanalyze_TC_Args;
OSDN Git Service
