Subversion Repositories openrisc_me

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             P A R . P R A G                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2009, 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.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the license.          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

--  Generally the parser checks the basic syntax of pragmas, but does not

--  do specialized syntax checks for individual pragmas, these are deferred

--  to semantic analysis time (see unit Sem_Prag). There are some pragmas

--  which require recognition and either partial or complete processing

--  during parsing, and this unit performs this required processing.

with Fname.UF; use Fname.UF;

with Osint;    use Osint;

with Rident;   use Rident;

with Restrict; use Restrict;

with Stringt;  use Stringt;

with Stylesw;  use Stylesw;

with Uintp;    use Uintp;

with Uname;    use Uname;

with System.WCh_Con; use System.WCh_Con;

separate (Par)

function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is

   Prag_Name   : constant Name_Id    := Pragma_Name (Pragma_Node);

   Prag_Id     : constant Pragma_Id  := Get_Pragma_Id (Prag_Name);

   Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node);

   Arg_Count   : Nat;

   Arg_Node    : Node_Id;

   -----------------------

   -- Local Subprograms --

   -----------------------

   function Arg1 return Node_Id;

   function Arg2 return Node_Id;

   function Arg3 return Node_Id;

   --  Obtain specified Pragma_Argument_Association. It is allowable to call

   --  the routine for the argument one past the last present argument, but

   --  that is the only case in which a non-present argument can be referenced.

   procedure Check_Arg_Count (Required : Int);

   --  Check argument count for pragma = Required.

   --  If not give error and raise Error_Resync.

   procedure Check_Arg_Is_String_Literal (Arg : Node_Id);

   --  Check the expression of the specified argument to make sure that it

   --  is a string literal. If not give error and raise Error_Resync.

   procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id);

   --  Check the expression of the specified argument to make sure that it

   --  is an identifier which is either ON or OFF, and if not, then issue

   --  an error message and raise Error_Resync.

   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

   --  Error_Resync is raised.

   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 Error_Resync raised.

   procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id);

   --  Same as Check_Optional_Identifier, except that the name is required

   --  to be present and to match the given Id value.

   procedure Process_Restrictions_Or_Restriction_Warnings;

   --  Common processing for Restrictions and Restriction_Warnings pragmas.

   --  This routine only processes the case of No_Obsolescent_Features,

   --  which is the only restriction that has syntactic effects. No general

   --  error checking is done, since this will be done in Sem_Prag. The

   --  other case processed is pragma Restrictions No_Dependence, since

   --  otherwise this is done too late.

   ----------

   -- Arg1 --

   ----------

   function Arg1 return Node_Id is

   begin

      return First (Pragma_Argument_Associations (Pragma_Node));

   end Arg1;

   ----------

   -- Arg2 --

   ----------

   function Arg2 return Node_Id is

   begin

      return Next (Arg1);

   end Arg2;

   ----------

   -- Arg3 --

   ----------

   function Arg3 return Node_Id is

   begin

      return Next (Arg2);

   end Arg3;

   ---------------------

   -- Check_Arg_Count --

   ---------------------

   procedure Check_Arg_Count (Required : Int) is

   begin

      if Arg_Count /= Required then

         Error_Msg ("wrong number of arguments for pragma%", Pragma_Sloc);

         raise Error_Resync;

      end if;

   end Check_Arg_Count;

   ----------------------------

   -- Check_Arg_Is_On_Or_Off --

   ----------------------------

   procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id) is

      Argx : constant Node_Id := Expression (Arg);

   begin

      if Nkind (Expression (Arg)) /= N_Identifier

        or else (Chars (Argx) /= Name_On

                   and then

                 Chars (Argx) /= Name_Off)

      then

         Error_Msg_Name_2 := Name_On;

         Error_Msg_Name_3 := Name_Off;

         Error_Msg

           ("argument for pragma% must be% or%", Sloc (Argx));

         raise Error_Resync;

      end if;

   end Check_Arg_Is_On_Or_Off;

   ---------------------------------

   -- Check_Arg_Is_String_Literal --

   ---------------------------------

   procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is

   begin

      if Nkind (Expression (Arg)) /= N_String_Literal then

         Error_Msg

           ("argument for pragma% must be string literal",

             Sloc (Expression (Arg)));

         raise Error_Resync;

      end if;

   end Check_Arg_Is_String_Literal;

   -------------------------

   -- Check_No_Identifier --

   -------------------------

   procedure Check_No_Identifier (Arg : Node_Id) is

   begin

      if Chars (Arg) /= No_Name then

         Error_Msg_N ("pragma% does not permit named arguments", Arg);

         raise Error_Resync;

      end if;

   end Check_No_Identifier;

   -------------------------------

   -- Check_Optional_Identifier --

   -------------------------------

   procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is

   begin

      if Present (Arg) and then Chars (Arg) /= No_Name then

         if Chars (Arg) /= Id then

            Error_Msg_Name_2 := Id;

            Error_Msg_N ("pragma% argument expects identifier%", Arg);

         end if;

      end if;

   end Check_Optional_Identifier;

   -------------------------------

   -- Check_Required_Identifier --

   -------------------------------

   procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id) is

   begin

      if Chars (Arg) /= Id then

         Error_Msg_Name_2 := Id;

         Error_Msg_N ("pragma% argument must have identifier%", Arg);

      end if;

   end Check_Required_Identifier;

   --------------------------------------------------

   -- Process_Restrictions_Or_Restriction_Warnings --

   --------------------------------------------------

   procedure Process_Restrictions_Or_Restriction_Warnings is

      Arg  : Node_Id;

      Id   : Name_Id;

      Expr : Node_Id;

   begin

      Arg := Arg1;

      while Present (Arg) loop

         Id := Chars (Arg);

         Expr := Expression (Arg);

         if Id = No_Name

           and then Nkind (Expr) = N_Identifier

           and then Get_Restriction_Id (Chars (Expr)) = No_Obsolescent_Features

         then

            Set_Restriction (No_Obsolescent_Features, Pragma_Node);

            Restriction_Warnings (No_Obsolescent_Features) :=

              Prag_Id = Pragma_Restriction_Warnings;

         elsif Id = Name_No_Dependence then

            Set_Restriction_No_Dependence

              (Unit => Expr,

               Warn => Prag_Id = Pragma_Restriction_Warnings

                         or else Treat_Restrictions_As_Warnings);

         end if;

         Next (Arg);

      end loop;

   end Process_Restrictions_Or_Restriction_Warnings;

--  Start of processing for Prag

begin

   Error_Msg_Name_1 := Prag_Name;

   --  Ignore unrecognized pragma. We let Sem post the warning for this, since

   --  it is a semantic error, not a syntactic one (we have already checked

   --  the syntax for the unrecognized pragma as required by (RM 2.8(11)).

   if Prag_Id = Unknown_Pragma then

      return Pragma_Node;

   end if;

   --  Count number of arguments. This loop also checks if any of the arguments

   --  are Error, indicating a syntax error as they were parsed. If so, we

   --  simply return, because we get into trouble with cascaded errors if we

   --  try to perform our error checks on junk arguments.

   Arg_Count := 0;

   if Present (Pragma_Argument_Associations (Pragma_Node)) then

      Arg_Node := Arg1;

      while Arg_Node /= Empty loop

         Arg_Count := Arg_Count + 1;

         if Expression (Arg_Node) = Error then

            return Error;

         end if;

         Next (Arg_Node);

      end loop;

   end if;

   --  Remaining processing is pragma dependent

   case Prag_Id is

      ------------

      -- Ada_83 --

      ------------

      --  This pragma must be processed at parse time, since we want to set

      --  the Ada version properly at parse time to recognize the appropriate

      --  Ada version syntax.

      when Pragma_Ada_83 =>

         Ada_Version := Ada_83;

         Ada_Version_Explicit := Ada_Version;

      ------------

      -- Ada_95 --

      ------------

      --  This pragma must be processed at parse time, since we want to set

      --  the Ada version properly at parse time to recognize the appropriate

      --  Ada version syntax.

      when Pragma_Ada_95 =>

         Ada_Version := Ada_95;

         Ada_Version_Explicit := Ada_Version;

      ---------------------

      -- Ada_05/Ada_2005 --

      ---------------------

      --  This pragma must be processed at parse time, since we want to set

      --  the Ada version properly at parse time to recognize the appropriate

      --  Ada version syntax. However, it is only the zero argument form that

      --  must be processed at parse time.

      when Pragma_Ada_05 | Pragma_Ada_2005 =>

         if Arg_Count = 0 then

            Ada_Version := Ada_05;

            Ada_Version_Explicit := Ada_05;

         end if;

      -----------

      -- Debug --

      -----------

      --  pragma Debug (PROCEDURE_CALL_STATEMENT);

      --  This has to be processed by the parser because of the very peculiar

      --  form of the second parameter, which is syntactically from a formal

      --  point of view a function call (since it must be an expression), but

      --  semantically we treat it as a procedure call (which has exactly the

      --  same syntactic form, so that's why we can get away with this!)

      when Pragma_Debug => Debug : declare

         Expr : Node_Id;

      begin

         if Arg_Count = 2 then

            Check_No_Identifier (Arg1);

            Check_No_Identifier (Arg2);

            Expr := New_Copy (Expression (Arg2));

         else

            Check_Arg_Count (1);

            Check_No_Identifier (Arg1);

            Expr := New_Copy (Expression (Arg1));

         end if;

         if Nkind (Expr) /= N_Indexed_Component

           and then Nkind (Expr) /= N_Function_Call

           and then Nkind (Expr) /= N_Identifier

           and then Nkind (Expr) /= N_Selected_Component

         then

            Error_Msg

              ("argument of pragma% is not procedure call", Sloc (Expr));

            raise Error_Resync;

         else

            Set_Debug_Statement

              (Pragma_Node, P_Statement_Name (Expr));

         end if;

      end Debug;

      -------------------------------

      -- Extensions_Allowed (GNAT) --

      -------------------------------

      --  pragma Extensions_Allowed (Off | On)

      --  The processing for pragma Extensions_Allowed must be done at

      --  parse time, since extensions mode may affect what is accepted.

      when Pragma_Extensions_Allowed =>

         Check_Arg_Count (1);

         Check_No_Identifier (Arg1);

         Check_Arg_Is_On_Or_Off (Arg1);

         if Chars (Expression (Arg1)) = Name_On then

            Extensions_Allowed := True;

         else

            Extensions_Allowed := False;

         end if;

      ----------------

      -- List (2.8) --

      ----------------

      --  pragma List (Off | On)

      --  The processing for pragma List must be done at parse time,

      --  since a listing can be generated in parse only mode.

      when Pragma_List =>

         Check_Arg_Count (1);

         Check_No_Identifier (Arg1);

         Check_Arg_Is_On_Or_Off (Arg1);

         --  We unconditionally make a List_On entry for the pragma, so that

         --  in the List (Off) case, the pragma will print even in a region

         --  of code with listing turned off (this is required!)

         List_Pragmas.Increment_Last;

         List_Pragmas.Table (List_Pragmas.Last) :=

           (Ptyp => List_On, Ploc => Sloc (Pragma_Node));

         --  Now generate the list off entry for pragma List (Off)

         if Chars (Expression (Arg1)) = Name_Off then

            List_Pragmas.Increment_Last;

            List_Pragmas.Table (List_Pragmas.Last) :=

              (Ptyp => List_Off, Ploc => Semi);

         end if;

      ----------------

      -- Page (2.8) --

      ----------------

      --  pragma Page;

      --  Processing for this pragma must be done at parse time, since a

      --  listing can be generated in parse only mode with semantics off.

      when Pragma_Page =>

         Check_Arg_Count (0);

         List_Pragmas.Increment_Last;

         List_Pragmas.Table (List_Pragmas.Last) := (Page, Semi);

         ------------------

         -- Restrictions --

         ------------------

         --  pragma Restrictions (RESTRICTION {, RESTRICTION});

         --  RESTRICTION ::=

         --    restriction_IDENTIFIER

         --  | restriction_parameter_IDENTIFIER => EXPRESSION

         --  We process the case of No_Obsolescent_Features, since this has

         --  a syntactic effect that we need to detect at parse time (the use

         --  of replacement characters such as colon for pound sign).

         when Pragma_Restrictions =>

            Process_Restrictions_Or_Restriction_Warnings;

         --------------------------

         -- Restriction_Warnings --

         --------------------------

         --  pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});

         --  RESTRICTION ::=

         --    restriction_IDENTIFIER

         --  | restriction_parameter_IDENTIFIER => EXPRESSION

         --  See above comment for pragma Restrictions

         when Pragma_Restriction_Warnings =>

            Process_Restrictions_Or_Restriction_Warnings;

      ----------------------------------------------------------

      -- Source_File_Name and Source_File_Name_Project (GNAT) --

      ----------------------------------------------------------

      --  These two pragmas have the same syntax and semantics.

      --  There are five forms of these pragmas:

      --  pragma Source_File_Name[_Project] (

      --    [UNIT_NAME      =>] unit_NAME,

      --     BODY_FILE_NAME =>  STRING_LITERAL

      --    [, [INDEX =>] INTEGER_LITERAL]);

      --  pragma Source_File_Name[_Project] (

      --    [UNIT_NAME      =>] unit_NAME,

      --     SPEC_FILE_NAME =>  STRING_LITERAL

      --    [, [INDEX =>] INTEGER_LITERAL]);

      --  pragma Source_File_Name[_Project] (

      --     BODY_FILE_NAME  => STRING_LITERAL

      --  [, DOT_REPLACEMENT => STRING_LITERAL]

      --  [, CASING          => CASING_SPEC]);

      --  pragma Source_File_Name[_Project] (

      --     SPEC_FILE_NAME  => STRING_LITERAL

      --  [, DOT_REPLACEMENT => STRING_LITERAL]

      --  [, CASING          => CASING_SPEC]);

      --  pragma Source_File_Name[_Project] (

      --     SUBUNIT_FILE_NAME  => STRING_LITERAL

      --  [, DOT_REPLACEMENT    => STRING_LITERAL]

      --  [, CASING             => CASING_SPEC]);

      --  CASING_SPEC ::= Uppercase | Lowercase | Mixedcase

      --  Pragma Source_File_Name_Project (SFNP) is equivalent to pragma

      --  Source_File_Name (SFN), however their usage is exclusive:

      --  SFN can only be used when no project file is used, while

      --  SFNP can only be used when a project file is used.

      --  The Project Manager produces a configuration pragmas file that

      --  is communicated to the compiler with -gnatec switch. This file

      --  contains only SFNP pragmas (at least two for the default naming

      --  scheme. As this configuration pragmas file is always the first

      --  processed by the compiler, it prevents the use of pragmas SFN in

      --  other config files when a project file is in use.

      --  Note: we process this during parsing, since we need to have the

      --  source file names set well before the semantic analysis starts,

      --  since we load the spec and with'ed packages before analysis.

      when Pragma_Source_File_Name | Pragma_Source_File_Name_Project =>

         Source_File_Name : declare

            Unam  : Unit_Name_Type;

            Expr1 : Node_Id;

            Pat   : String_Ptr;

            Typ   : Character;

            Dot   : String_Ptr;

            Cas   : Casing_Type;

            Nast  : Nat;

            Expr  : Node_Id;

            Index : Nat;

            function Get_Fname (Arg : Node_Id) return File_Name_Type;

            --  Process file name from unit name form of pragma

            function Get_String_Argument (Arg : Node_Id) return String_Ptr;

            --  Process string literal value from argument

            procedure Process_Casing (Arg : Node_Id);

            --  Process Casing argument of pattern form of pragma

            procedure Process_Dot_Replacement (Arg : Node_Id);

            --  Process Dot_Replacement argument of pattern form of pragma

            ---------------

            -- Get_Fname --

            ---------------

            function Get_Fname (Arg : Node_Id) return File_Name_Type is

            begin

               String_To_Name_Buffer (Strval (Expression (Arg)));

               for J in 1 .. Name_Len loop

                  if Is_Directory_Separator (Name_Buffer (J)) then

                     Error_Msg

                       ("directory separator character not allowed",

                        Sloc (Expression (Arg)) + Source_Ptr (J));

                  end if;

               end loop;

               return Name_Find;

            end Get_Fname;

            -------------------------

            -- Get_String_Argument --

            -------------------------

            function Get_String_Argument (Arg : Node_Id) return String_Ptr is

               Str : String_Id;

            begin

               if Nkind (Expression (Arg)) /= N_String_Literal

                 and then

                  Nkind (Expression (Arg)) /= N_Operator_Symbol

               then

                  Error_Msg_N

                    ("argument for pragma% must be string literal", Arg);

                  raise Error_Resync;

               end if;

               Str := Strval (Expression (Arg));

               --  Check string has no wide chars

               for J in 1 .. String_Length (Str) loop

                  if Get_String_Char (Str, J) > 255 then

                     Error_Msg

                       ("wide character not allowed in pattern for pragma%",

                        Sloc (Expression (Arg2)) + Text_Ptr (J) - 1);

                  end if;

               end loop;

               --  Acquire string

               String_To_Name_Buffer (Str);

               return new String'(Name_Buffer (1 .. Name_Len));

            end Get_String_Argument;

            --------------------

            -- Process_Casing --

            --------------------

            procedure Process_Casing (Arg : Node_Id) is

               Expr : constant Node_Id := Expression (Arg);

            begin

               Check_Required_Identifier (Arg, Name_Casing);

               if Nkind (Expr) = N_Identifier then

                  if Chars (Expr) = Name_Lowercase then

                     Cas := All_Lower_Case;

                     return;

                  elsif Chars (Expr) = Name_Uppercase then

                     Cas := All_Upper_Case;

                     return;

                  elsif Chars (Expr) = Name_Mixedcase then

                     Cas := Mixed_Case;

                     return;

                  end if;

               end if;

               Error_Msg_N

                 ("Casing argument for pragma% must be " &

                  "one of Mixedcase, Lowercase, Uppercase",

                  Arg);

            end Process_Casing;

            -----------------------------

            -- Process_Dot_Replacement --

            -----------------------------

            procedure Process_Dot_Replacement (Arg : Node_Id) is

            begin

               Check_Required_Identifier (Arg, Name_Dot_Replacement);

               Dot := Get_String_Argument (Arg);

            end Process_Dot_Replacement;

         --  Start of processing for Source_File_Name and

         --  Source_File_Name_Project pragmas.

         begin

            if Prag_Id = Pragma_Source_File_Name then

               if Project_File_In_Use = In_Use then

                  Error_Msg

                    ("pragma Source_File_Name cannot be used " &

                     "with a project file", Pragma_Sloc);

               else

                  Project_File_In_Use := Not_In_Use;

               end if;

            else

               if Project_File_In_Use = Not_In_Use then

                  Error_Msg

                    ("pragma Source_File_Name_Project should only be used " &

                     "with a project file", Pragma_Sloc);

               else

                  Project_File_In_Use := In_Use;

               end if;

            end if;

            --  We permit from 1 to 3 arguments

            if Arg_Count not in 1 .. 3 then

               Check_Arg_Count (1);

            end if;

            Expr1 := Expression (Arg1);

            --  If first argument is identifier or selected component, then

            --  we have the specific file case of the Source_File_Name pragma,

            --  and the first argument is a unit name.

            if Nkind (Expr1) = N_Identifier

              or else

                (Nkind (Expr1) = N_Selected_Component

                  and then

                 Nkind (Selector_Name (Expr1)) = N_Identifier)

            then

               if Nkind (Expr1) = N_Identifier

                 and then Chars (Expr1) = Name_System

               then

                  Error_Msg_N

                    ("pragma Source_File_Name may not be used for System",

                     Arg1);

                  return Error;

               end if;

               --  Process index argument if present

               if Arg_Count = 3 then

                  Expr := Expression (Arg3);

                  if Nkind (Expr) /= N_Integer_Literal

                    or else not UI_Is_In_Int_Range (Intval (Expr))

                    or else Intval (Expr) > 999

                    or else Intval (Expr) <= 0

                  then

                     Error_Msg

                       ("pragma% index must be integer literal" &

                        " in range 1 .. 999", Sloc (Expr));

                     raise Error_Resync;

                  else

                     Index := UI_To_Int (Intval (Expr));

                  end if;

               --  No index argument present

               else

                  Check_Arg_Count (2);

                  Index := 0;

               end if;

               Check_Optional_Identifier (Arg1, Name_Unit_Name);

               Unam := Get_Unit_Name (Expr1);

               Check_Arg_Is_String_Literal (Arg2);

               if Chars (Arg2) = Name_Spec_File_Name then

                  Set_File_Name

                    (Get_Spec_Name (Unam), Get_Fname (Arg2), Index);

               elsif Chars (Arg2) = Name_Body_File_Name then

                  Set_File_Name

                    (Unam, Get_Fname (Arg2), Index);

               else

                  Error_Msg_N

                    ("pragma% argument has incorrect identifier", Arg2);

                  return Pragma_Node;

               end if;

            --  If the first argument is not an identifier, then we must have

            --  the pattern form of the pragma, and the first argument must be

            --  the pattern string with an appropriate name.

            else

               if Chars (Arg1) = Name_Spec_File_Name then

                  Typ := 's';

               elsif Chars (Arg1) = Name_Body_File_Name then

                  Typ := 'b';

               elsif Chars (Arg1) = Name_Subunit_File_Name then

                  Typ := 'u';

               elsif Chars (Arg1) = Name_Unit_Name then

                  Error_Msg_N

                    ("Unit_Name parameter for pragma% must be an identifier",

                     Arg1);

                  raise Error_Resync;

               else

                  Error_Msg_N

                    ("pragma% argument has incorrect identifier", Arg1);

                  raise Error_Resync;

               end if;

               Pat := Get_String_Argument (Arg1);

               --  Check pattern has exactly one asterisk

               Nast := 0;

               for J in Pat'Range loop

                  if Pat (J) = '*' then

                     Nast := Nast + 1;

                  end if;

               end loop;

               if Nast /= 1 then

                  Error_Msg_N

                    ("file name pattern must have exactly one * character",

                     Arg1);

                  return Pragma_Node;

               end if;

               --  Set defaults for Casing and Dot_Separator parameters

               Cas := All_Lower_Case;

               Dot := new String'(".");

               --  Process second and third arguments if present

               if Arg_Count > 1 then

                  if Chars (Arg2) = Name_Casing then

                     Process_Casing (Arg2);

                     if Arg_Count = 3 then

                        Process_Dot_Replacement (Arg3);

                     end if;

                  else

                     Process_Dot_Replacement (Arg2);

                     if Arg_Count = 3 then

                        Process_Casing (Arg3);

                     end if;

                  end if;

               end if;

               Set_File_Name_Pattern (Pat, Typ, Dot, Cas);

            end if;