New Language: Ada

From-SVN: r45956

gcc/ada/par-ch11.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . C H 1 1                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.22 $
+--                                                                          --
+--          Copyright (C) 1992-2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+with Sinfo.CN; use Sinfo.CN;
+
+separate (Par)
+package body Ch11 is
+
+   --  Local functions, used only in this chapter
+
+   function P_Exception_Handler  return Node_Id;
+   function P_Exception_Choice   return Node_Id;
+
+   ---------------------------------
+   -- 11.1  Exception Declaration --
+   ---------------------------------
+
+   --  Parsed by P_Identifier_Declaration (3.3.1)
+
+   ------------------------------------------
+   -- 11.2  Handled Sequence Of Statements --
+   ------------------------------------------
+
+   --  HANDLED_SEQUENCE_OF_STATEMENTS ::=
+   --      SEQUENCE_OF_STATEMENTS
+   --    [exception
+   --      EXCEPTION_HANDLER
+   --      {EXCEPTION_HANDLER}]
+
+   --  Error_Recovery : Cannot raise Error_Resync
+
+   function P_Handled_Sequence_Of_Statements return Node_Id is
+      Handled_Stmt_Seq_Node : Node_Id;
+
+   begin
+      Handled_Stmt_Seq_Node :=
+        New_Node (N_Handled_Sequence_Of_Statements, Token_Ptr);
+      Set_Statements
+        (Handled_Stmt_Seq_Node, P_Sequence_Of_Statements (SS_Extm_Sreq));
+
+      if Token = Tok_Exception then
+         Scan; -- past EXCEPTION
+         Set_Exception_Handlers
+           (Handled_Stmt_Seq_Node, Parse_Exception_Handlers);
+      end if;
+
+      return Handled_Stmt_Seq_Node;
+   end P_Handled_Sequence_Of_Statements;
+
+   -----------------------------
+   -- 11.2  Exception Handler --
+   -----------------------------
+
+   --  EXCEPTION_HANDLER ::=
+   --    when [CHOICE_PARAMETER_SPECIFICATION :]
+   --      EXCEPTION_CHOICE {| EXCEPTION_CHOICE} =>
+   --        SEQUENCE_OF_STATEMENTS
+
+   --  CHOICE_PARAMETER_SPECIFICATION ::= DEFINING_IDENTIFIER
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Exception_Handler return Node_Id is
+      Scan_State        : Saved_Scan_State;
+      Handler_Node      : Node_Id;
+      Choice_Param_Node : Node_Id;
+
+   begin
+      Handler_Node := New_Node (N_Exception_Handler, Token_Ptr);
+      T_When;
+
+      --  Test for possible choice parameter present
+
+      if Token = Tok_Identifier then
+         Choice_Param_Node := Token_Node;
+         Save_Scan_State (Scan_State); -- at identifier
+         Scan; -- past identifier
+
+         if Token = Tok_Colon then
+            if Ada_83 then
+               Error_Msg_SP ("(Ada 83) choice parameter not allowed!");
+            end if;
+
+            Scan; -- past :
+            Change_Identifier_To_Defining_Identifier (Choice_Param_Node);
+            Set_Choice_Parameter (Handler_Node, Choice_Param_Node);
+
+         elsif Token = Tok_Others then
+            Error_Msg_AP ("missing "":""");
+            Change_Identifier_To_Defining_Identifier (Choice_Param_Node);
+            Set_Choice_Parameter (Handler_Node, Choice_Param_Node);
+
+         else
+            Restore_Scan_State (Scan_State); -- to identifier
+         end if;
+      end if;
+
+      --  Loop through exception choices
+
+      Set_Exception_Choices (Handler_Node, New_List);
+
+      loop
+         Append (P_Exception_Choice, Exception_Choices (Handler_Node));
+         exit when Token /= Tok_Vertical_Bar;
+         Scan; -- past vertical bar
+      end loop;
+
+      TF_Arrow;
+      Set_Statements (Handler_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm));
+      return Handler_Node;
+   end P_Exception_Handler;
+
+   ------------------------------------------
+   -- 11.2  Choice Parameter Specification --
+   ------------------------------------------
+
+   --  Parsed by P_Exception_Handler (11.2)
+
+   ----------------------------
+   -- 11.2  Exception Choice --
+   ----------------------------
+
+   --  EXCEPTION_CHOICE ::= exception_NAME | others
+
+   --  Error recovery: cannot raise Error_Resync. If an error occurs, then the
+   --  scan pointer is advanced to the next arrow or vertical bar or semicolon.
+
+   function P_Exception_Choice return Node_Id is
+   begin
+
+      if Token = Tok_Others then
+         Scan; -- past OTHERS
+         return New_Node (N_Others_Choice, Prev_Token_Ptr);
+
+      else
+         return P_Name; -- exception name
+      end if;
+
+   exception
+      when Error_Resync =>
+         Resync_Choice;
+         return Error;
+   end P_Exception_Choice;
+
+   ---------------------------
+   -- 11.3  Raise Statement --
+   ---------------------------
+
+   --  RAISE_STATEMENT ::= raise [exception_NAME];
+
+   --  The caller has verified that the initial token is RAISE
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Raise_Statement return Node_Id is
+      Raise_Node : Node_Id;
+
+   begin
+      Raise_Node := New_Node (N_Raise_Statement, Token_Ptr);
+      Scan; -- past RAISE
+
+      if Token /= Tok_Semicolon then
+         Set_Name (Raise_Node, P_Name);
+      end if;
+
+      TF_Semicolon;
+      return Raise_Node;
+   end P_Raise_Statement;
+
+   ------------------------------
+   -- Parse_Exception_Handlers --
+   ------------------------------
+
+   --  This routine scans out a list of exception handlers appearing in a
+   --  construct as:
+
+   --    exception
+   --      EXCEPTION_HANDLER {EXCEPTION_HANDLER}
+
+   --  The caller has scanned out the EXCEPTION keyword
+
+   --  Control returns after scanning the last exception handler, presumably
+   --  at the keyword END, but this is not checked in this routine.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function Parse_Exception_Handlers return List_Id is
+      Handler       : Node_Id;
+      Handlers_List : List_Id;
+      Pragmas_List  : List_Id;
+
+   begin
+      Handlers_List := New_List;
+      P_Pragmas_Opt (Handlers_List);
+
+      if Token = Tok_End then
+         Error_Msg_SC ("must have at least one exception handler!");
+
+      else
+         loop
+            Handler := P_Exception_Handler;
+            Pragmas_List := No_List;
+            Append (Handler, Handlers_List);
+
+            --  Note: no need to check for pragmas here. Although the
+            --  syntax officially allows them in this position, they
+            --  will have been swallowed up as part of the statement
+            --  sequence of the handler we just scanned out.
+
+            exit when Token /= Tok_When;
+         end loop;
+      end if;
+
+      return Handlers_List;
+   end Parse_Exception_Handlers;
+
+end Ch11;

gcc/ada/par-ch8.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P A R . C H 8                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.16 $
+--                                                                          --
+--          Copyright (C) 1992-2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+separate (Par)
+package body Ch8 is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   function P_Use_Package_Clause                           return Node_Id;
+   function P_Use_Type_Clause                              return Node_Id;
+
+   ---------------------
+   -- 8.4  Use Clause --
+   ---------------------
+
+   --  USE_CLAUSE ::= USE_PACKAGE_CLAUSE | USE_TYPE_CLAUSE
+
+   --  The caller has checked that the initial token is USE
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Use_Clause return Node_Id is
+   begin
+      Scan; -- past USE
+
+      if Token = Tok_Type then
+         return P_Use_Type_Clause;
+
+      else
+         return P_Use_Package_Clause;
+      end if;
+   end P_Use_Clause;
+
+   -----------------------------
+   -- 8.4  Use Package Clause --
+   -----------------------------
+
+   --  USE_PACKAGE_CLAUSE ::= use package_NAME {, package_NAME};
+
+   --  The caller has scanned out the USE keyword
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Use_Package_Clause return Node_Id is
+      Use_Node : Node_Id;
+
+   begin
+      Use_Node := New_Node (N_Use_Package_Clause, Prev_Token_Ptr);
+      Set_Names (Use_Node, New_List);
+
+      if Token = Tok_Package then
+         Error_Msg_SC ("PACKAGE should not appear here");
+         Scan; -- past PACKAGE
+      end if;
+
+      loop
+         Append (P_Qualified_Simple_Name, Names (Use_Node));
+         exit when Token /= Tok_Comma;
+         Scan; -- past comma
+      end loop;
+
+      TF_Semicolon;
+      return Use_Node;
+   end P_Use_Package_Clause;
+
+   --------------------------
+   -- 8.4  Use Type Clause --
+   --------------------------
+
+   --  USE_TYPE_CLAUSE ::= use type SUBTYPE_MARK {, SUBTYPE_MARK};
+
+   --  The caller has checked that the initial token is USE, scanned it out
+   --  and that the current token is TYPE.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Use_Type_Clause return Node_Id is
+      Use_Node : Node_Id;
+
+   begin
+      Use_Node := New_Node (N_Use_Type_Clause, Prev_Token_Ptr);
+      Set_Subtype_Marks (Use_Node, New_List);
+
+      if Ada_83 then
+         Error_Msg_SC ("(Ada 83) use type not allowed!");
+      end if;
+
+      Scan; -- past TYPE
+
+      loop
+         Append (P_Subtype_Mark, Subtype_Marks (Use_Node));
+         No_Constraint;
+         exit when Token /= Tok_Comma;
+         Scan; -- past comma
+      end loop;
+
+      TF_Semicolon;
+      return Use_Node;
+   end P_Use_Type_Clause;
+
+   -------------------------------
+   -- 8.5  Renaming Declaration --
+   -------------------------------
+
+   --  Object renaming declarations and exception renaming declarations
+   --  are parsed by P_Identifier_Declaration (3.3.1)
+
+   --  Subprogram renaming declarations are parsed by P_Subprogram (6.1)
+
+   --  Package renaming declarations are parsed by P_Package (7.1)
+
+   --  Generic renaming declarations are parsed by P_Generic (12.1)
+
+   ----------------------------------------
+   -- 8.5.1  Object Renaming Declaration --
+   ----------------------------------------
+
+   --  Parsed by P_Identifier_Declarations (3.3.1)
+
+   ----------------------------------------
+   -- 8.5.2  Exception Renaming Declaration --
+   ----------------------------------------
+
+   --  Parsed by P_Identifier_Declarations (3.3.1)
+
+   -----------------------------------------
+   -- 8.5.3  Package Renaming Declaration --
+   -----------------------------------------
+
+   --  Parsed by P_Package (7.1)
+
+   --------------------------------------------
+   -- 8.5.4  Subprogram Renaming Declaration --
+   --------------------------------------------
+
+   --  Parsed by P_Subprogram (6.1)
+
+   -----------------------------------------
+   -- 8.5.2  Generic Renaming Declaration --
+   -----------------------------------------
+
+   --  Parsed by P_Generic (12.1)
+
+end Ch8;

gcc/ada/par-labl.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . L A B L                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.18 $                             --
+--                                                                          --
+--          Copyright (C) 1992-1998, 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+separate (Par)
+procedure Labl is
+   Enclosing_Body_Or_Block : Node_Id;
+   --  Innermost enclosing body or block statement
+
+   Label_Decl_Node : Node_Id;
+   --  Implicit label declaration node
+
+   Defining_Ident_Node : Node_Id;
+   --  Defining identifier node for implicit label declaration
+
+   Next_Label_Elmt : Elmt_Id;
+   --  Next element on label element list
+
+   Label_Node : Node_Id;
+   --  Next label node to process
+
+   function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id;
+   --  Find the innermost body or block that encloses N.
+
+   function Find_Enclosing_Body (N : Node_Id) return Node_Id;
+   --  Find the innermost body that encloses N.
+
+   procedure Check_Distinct_Labels;
+   --  Checks the rule in RM-5.1(11), which requires distinct identifiers
+   --  for all the labels in a given body.
+
+   ---------------------------
+   -- Check_Distinct_Labels --
+   ---------------------------
+
+   procedure Check_Distinct_Labels is
+      Label_Id : constant Node_Id := Identifier (Label_Node);
+
+      Enclosing_Body : constant Node_Id :=
+                         Find_Enclosing_Body (Enclosing_Body_Or_Block);
+      --  Innermost enclosing body
+
+      Next_Other_Label_Elmt : Elmt_Id := First_Elmt (Label_List);
+      --  Next element on label element list
+
+      Other_Label : Node_Id;
+      --  Next label node to process
+
+   begin
+      --  Loop through all the labels, and if we find some other label
+      --  (i.e. not Label_Node) that has the same identifier,
+      --  and whose innermost enclosing body is the same,
+      --  then we have an error.
+
+      --  Note that in the worst case, this is quadratic in the number
+      --  of labels.  However, labels are not all that common, and this
+      --  is only called for explicit labels.
+      --  ???Nonetheless, the efficiency could be improved. For example,
+      --  call Labl for each body, rather than once per compilation.
+
+      while Present (Next_Other_Label_Elmt) loop
+         Other_Label := Node (Next_Other_Label_Elmt);
+
+         exit when Label_Node = Other_Label;
+
+         if Chars (Label_Id) = Chars (Identifier (Other_Label))
+           and then Enclosing_Body = Find_Enclosing_Body (Other_Label)
+         then
+            Error_Msg_Sloc := Sloc (Other_Label);
+            Error_Msg_N ("& conflicts with label#", Label_Id);
+            exit;
+         end if;
+
+         Next_Elmt (Next_Other_Label_Elmt);
+      end loop;
+   end Check_Distinct_Labels;
+
+   -------------------------
+   -- Find_Enclosing_Body --
+   -------------------------
+
+   function Find_Enclosing_Body (N : Node_Id) return Node_Id is
+      Result : Node_Id := N;
+
+   begin
+      --  This is the same as Find_Enclosing_Body_Or_Block, except
+      --  that we skip block statements and accept statements, instead
+      --  of stopping at them.
+
+      while Present (Result)
+        and then Nkind (Result) /= N_Entry_Body
+        and then Nkind (Result) /= N_Task_Body
+        and then Nkind (Result) /= N_Package_Body
+        and then Nkind (Result) /= N_Subprogram_Body
+      loop
+         Result := Parent (Result);
+      end loop;
+
+      return Result;
+   end Find_Enclosing_Body;
+
+   ----------------------------------
+   -- Find_Enclosing_Body_Or_Block --
+   ----------------------------------
+
+   function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id is
+      Result : Node_Id := Parent (N);
+
+   begin
+      --  Climb up the parent chain until we find a body or block.
+
+      while Present (Result)
+        and then Nkind (Result) /= N_Accept_Statement
+        and then Nkind (Result) /= N_Entry_Body
+        and then Nkind (Result) /= N_Task_Body
+        and then Nkind (Result) /= N_Package_Body
+        and then Nkind (Result) /= N_Subprogram_Body
+        and then Nkind (Result) /= N_Block_Statement
+      loop
+         Result := Parent (Result);
+      end loop;
+
+      return Result;
+   end Find_Enclosing_Body_Or_Block;
+
+--  Start of processing for Par.Labl
+
+begin
+   Next_Label_Elmt := First_Elmt (Label_List);
+
+   while Present (Next_Label_Elmt) loop
+      Label_Node := Node (Next_Label_Elmt);
+
+      if not Comes_From_Source (Label_Node) then
+         goto Next_Label;
+      end if;
+
+      --  Find the innermost enclosing body or block, which is where
+      --  we need to implicitly declare this label
+
+      Enclosing_Body_Or_Block := Find_Enclosing_Body_Or_Block (Label_Node);
+
+      --  If we didn't find a parent, then the label in question never got
+      --  hooked into a reasonable declarative part. This happens only in
+      --  error situations, and we simply ignore the entry (we aren't going
+      --  to get into the semantics in any case given the error).
+
+      if Present (Enclosing_Body_Or_Block) then
+         Check_Distinct_Labels;
+
+         --  Now create the implicit label declaration node and its
+         --  corresponding defining identifier. Note that the defining
+         --  occurrence of a label is the implicit label declaration that
+         --  we are creating. The label itself is an applied occurrence.
+
+         Label_Decl_Node :=
+           New_Node (N_Implicit_Label_Declaration, Sloc (Label_Node));
+         Defining_Ident_Node :=
+           New_Entity (N_Defining_Identifier, Sloc (Identifier (Label_Node)));
+         Set_Chars (Defining_Ident_Node, Chars (Identifier (Label_Node)));
+         Set_Defining_Identifier (Label_Decl_Node, Defining_Ident_Node);
+         Set_Label_Construct (Label_Decl_Node, Label_Node);
+
+         --  Now attach the implicit label declaration to the appropriate
+         --  declarative region, creating a declaration list if none exists
+
+         if not Present (Declarations (Enclosing_Body_Or_Block)) then
+            Set_Declarations (Enclosing_Body_Or_Block, New_List);
+         end if;
+
+         Append (Label_Decl_Node, Declarations (Enclosing_Body_Or_Block));
+      end if;
+
+      <<Next_Label>>
+         Next_Elmt (Next_Label_Elmt);
+   end loop;
+
+end Labl;

gcc/ada/par-sync.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . S Y N C                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.19 $
+--                                                                          --
+--          Copyright (C) 1992-2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+separate (Par)
+package body Sync is
+
+   procedure Resync_Init;
+   --  This routine is called on initiating a resynchronization action
+
+   procedure Resync_Resume;
+   --  This routine is called on completing a resynchronization action
+
+   -------------------
+   -- Resync_Choice --
+   -------------------
+
+   procedure Resync_Choice is
+   begin
+      Resync_Init;
+
+      --  Loop till we get a token that terminates a choice. Note that EOF is
+      --  one such token, so we are sure to get out of this loop eventually!
+
+      while Token not in Token_Class_Cterm loop
+         Scan;
+      end loop;
+
+      Resync_Resume;
+   end Resync_Choice;
+
+   ------------------
+   -- Resync_Cunit --
+   ------------------
+
+   procedure Resync_Cunit is
+   begin
+      Resync_Init;
+
+      while Token not in Token_Class_Cunit
+        and then Token /= Tok_EOF
+      loop
+         Scan;
+      end loop;
+
+      Resync_Resume;
+   end Resync_Cunit;
+
+   -----------------------
+   -- Resync_Expression --
+   -----------------------
+
+   procedure Resync_Expression is
+      Paren_Count : Int;
+
+   begin
+      Resync_Init;
+      Paren_Count := 0;
+
+      loop
+         --  Terminating tokens are those in class Eterm and also RANGE,
+         --  DIGITS or DELTA if not preceded by an apostrophe (if they are
+         --  preceded by an apostrophe, then they are attributes). In addiion,
+         --  at the outer parentheses level only, we also consider a comma,
+         --  right parenthesis or vertical bar to terminate an expression.
+
+         if Token in Token_Class_Eterm
+
+           or else (Token in Token_Class_Atkwd
+                     and then Prev_Token /= Tok_Apostrophe)
+
+           or else (Paren_Count = 0
+                     and then
+                       (Token = Tok_Comma
+                         or else Token = Tok_Right_Paren
+                         or else Token = Tok_Vertical_Bar))
+         then
+            --  A special check: if we stop on the ELSE of OR ELSE or the
+            --  THEN of AND THEN, keep going, because this is not really an
+            --  expression terminator after all. Also, keep going past WITH
+            --  since this can be part of an extension aggregate
+
+            if (Token = Tok_Else and then Prev_Token = Tok_Or)
+               or else (Token = Tok_Then and then Prev_Token = Tok_And)
+               or else Token = Tok_With
+            then
+               null;
+            else
+               exit;
+            end if;
+         end if;
+
+         if Token = Tok_Left_Paren then
+            Paren_Count := Paren_Count + 1;
+
+         elsif Token = Tok_Right_Paren then
+            Paren_Count := Paren_Count - 1;
+
+         end if;
+
+         Scan; -- past token to be skipped
+      end loop;
+
+      Resync_Resume;
+   end Resync_Expression;
+
+   -----------------
+   -- Resync_Init --
+   -----------------
+
+   procedure Resync_Init is
+   begin
+      --  The following check makes sure we do not get stuck in an infinite
+      --  loop resynchonizing and getting nowhere. If we are called to do a
+      --  resynchronize and we are exactly at the same point that we left off
+      --  on the last resynchronize call, then we force at least one token to
+      --  be skipped so that we make progress!
+
+      if Token_Ptr = Last_Resync_Point then
+         Scan; -- to skip at least one token
+      end if;
+
+      --  Output extra error message if debug R flag is set
+
+      if Debug_Flag_R then
+         Error_Msg_SC ("resynchronizing!");
+      end if;
+   end Resync_Init;
+
+   ---------------------------
+   -- Resync_Past_Semicolon --
+   ---------------------------
+
+   procedure Resync_Past_Semicolon is
+   begin
+      Resync_Init;
+
+      loop
+         --  Done if we are at a semicolon
+
+         if Token = Tok_Semicolon then
+            Scan; -- past semicolon
+            exit;
+
+         --  Done if we are at a token which normally appears only after
+         --  a semicolon. One special glitch is that the keyword private is
+         --  in this category only if it does NOT appear after WITH.
+
+         elsif Token in Token_Class_After_SM
+            and then (Token /= Tok_Private or else Prev_Token /= Tok_With)
+         then
+            exit;
+
+         --  Otherwise keep going
+
+         else
+            Scan;
+         end if;
+      end loop;
+
+      --  Fall out of loop with resyncrhonization complete
+
+      Resync_Resume;
+   end Resync_Past_Semicolon;
+
+   ----------------------------------------------
+   -- Resync_Past_Semicolon_Or_To_Loop_Or_Then --
+   ----------------------------------------------
+
+   procedure Resync_Past_Semicolon_Or_To_Loop_Or_Then is
+   begin
+      Resync_Init;
+
+      loop
+         --  Done if at semicolon
+
+         if Token = Tok_Semicolon then
+            Scan; -- past the semicolon
+            exit;
+
+         --  Done if we are at a token which normally appears only after
+         --  a semicolon. One special glitch is that the keyword private is
+         --  in this category only if it does NOT appear after WITH.
+
+         elsif (Token in Token_Class_After_SM
+                  and then (Token /= Tok_Private
+                              or else Prev_Token /= Tok_With))
+         then
+            exit;
+
+         --  Done if we are at THEN or LOOP
+
+         elsif Token = Tok_Then or else Token = Tok_Loop then
+            exit;
+
+         --  Otherwise keep going
+
+         else
+            Scan;
+         end if;
+      end loop;
+
+      --  Fall out of loop with resyncrhonization complete
+
+      Resync_Resume;
+   end Resync_Past_Semicolon_Or_To_Loop_Or_Then;
+
+   -------------------
+   -- Resync_Resume --
+   -------------------
+
+   procedure Resync_Resume is
+   begin
+      --  Save resync point (see special test in Resync_Init)
+
+      Last_Resync_Point := Token_Ptr;
+
+      if Debug_Flag_R then
+         Error_Msg_SC ("resuming here!");
+      end if;
+   end Resync_Resume;
+
+   --------------------
+   -- Resync_To_When --
+   --------------------
+
+   procedure Resync_To_When is
+   begin
+      Resync_Init;
+
+      loop
+         --  Done if at semicolon, WHEN or IS
+
+         if Token = Tok_Semicolon
+           or else Token = Tok_When
+           or else Token = Tok_Is
+         then
+            exit;
+
+         --  Otherwise keep going
+
+         else
+            Scan;
+         end if;
+      end loop;
+
+      --  Fall out of loop with resyncrhonization complete
+
+      Resync_Resume;
+   end Resync_To_When;
+
+   ---------------------------
+   -- Resync_Semicolon_List --
+   ---------------------------
+
+   procedure Resync_Semicolon_List is
+      Paren_Count : Int;
+
+   begin
+      Resync_Init;
+      Paren_Count := 0;
+
+      loop
+         if Token = Tok_EOF
+           or else Token = Tok_Semicolon
+           or else Token = Tok_Is
+           or else Token in Token_Class_After_SM
+         then
+            exit;
+
+         elsif Token = Tok_Left_Paren then
+            Paren_Count := Paren_Count + 1;
+
+         elsif Token = Tok_Right_Paren then
+            if Paren_Count = 0 then
+               exit;
+            else
+               Paren_Count := Paren_Count - 1;
+            end if;
+         end if;
+
+         Scan;
+      end loop;
+
+      Resync_Resume;
+   end Resync_Semicolon_List;
+
+end Sync;

gcc/ada/par.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                  P A R                                   --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.14 $                             --
+--                                                                          --
+--     Copyright (C) 1992,1993,1994,1995 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  The Par function and its subunits contains all the parsing routines
+--  for the top down recursive descent parser that constructs the parse tree
+
+with Types; use Types;
+
+function Par (Configuration_Pragmas : Boolean) return List_Id;
+--  Top level parsing routine. There are two cases:
+--
+--  If Configuration_Pragmas is False, Par parses a compilation unit in the
+--  current source file and sets the Cunit, Cunit_Entity and Unit_Name fields
+--  of the units table entry for Current_Source_Unit. On return the parse tree
+--  is complete, and decorated with any required implicit label declarations.
+--  The value returned in this case is always No_List.
+--
+--  If Configuration_Pragmas is True, Par parses a list of configuration
+--  pragmas from the current source file, and returns the list of pragmas.

gcc/ada/prj-attr.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . A T T R                             --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.4 $
+--                                                                          --
+--             Copyright (C) 2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Namet;     use Namet;
+with Output;    use Output;
+
+package body Prj.Attr is
+
+   --  Names end with '#'
+   --  Package names are preceded by 'P'
+   --  Attribute names are preceded by two capital letters:
+   --    'S' for Single or 'L' for list, then
+   --    'V' for single variable, 'A' for associative array, or 'B' for both.
+   --  End is indicated by two consecutive '#'.
+
+   Initialisation_Data : constant String :=
+
+   --  project attributes
+
+     "SVobject_dir#" &
+     "LVsource_dirs#" &
+     "LVsource_files#" &
+     "SVsource_list_file#" &
+     "SVlibrary_dir#" &
+     "SVlibrary_name#" &
+     "SVlibrary_kind#" &
+     "SVlibrary_elaboration#" &
+     "SVlibrary_version#" &
+     "LVmain#" &
+
+   --  package Naming
+
+     "Pnaming#" &
+     "SVspecification_append#" &
+     "SVbody_append#" &
+     "SVseparate_append#" &
+     "SVcasing#" &
+     "SVdot_replacement#" &
+     "SAspecification#" &
+     "SAbody_part#" &
+
+   --  package Compiler
+
+     "Pcompiler#" &
+     "LBswitches#" &
+     "SVlocal_configuration_pragmas#" &
+
+   --  package gnatmake
+
+     "Pgnatmake#" &
+     "LBswitches#" &
+     "SVglobal_configuration_pragmas#" &
+
+   --  package gnatls
+
+     "Pgnatls#" &
+     "LVswitches#" &
+
+   --  package gnatbind
+
+     "Pgnatbind#" &
+     "LBswitches#" &
+
+   --  package gnatlink
+
+     "Pgnatlink#" &
+     "LBswitches#" &
+
+     "#";
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+      Start             : Positive           := Initialisation_Data'First;
+      Finish            : Positive           := Start;
+      Current_Package   : Package_Node_Id    := Empty_Package;
+      Current_Attribute : Attribute_Node_Id  := Empty_Attribute;
+      Is_An_Attribute   : Boolean            := False;
+      Kind_1            : Variable_Kind      := Undefined;
+      Kind_2            : Attribute_Kind     := Single;
+      Package_Name      : Name_Id            := No_Name;
+      Attribute_Name    : Name_Id            := No_Name;
+      First_Attribute   : Attribute_Node_Id  := Attribute_First;
+   begin
+
+      --  Make sure the two tables are empty
+
+      Attributes.Set_Last (Attributes.First);
+      Package_Attributes.Set_Last (Package_Attributes.First);
+
+      while Initialisation_Data (Start) /= '#' loop
+         Is_An_Attribute := True;
+         case Initialisation_Data (Start) is
+            when 'P' =>
+               --  New allowed package
+               Start := Start + 1;
+               Finish := Start;
+               while Initialisation_Data (Finish) /= '#' loop
+                  Finish := Finish + 1;
+               end loop;
+               Name_Len := Finish - Start;
+               Name_Buffer (1 .. Name_Len) :=
+                 To_Lower (Initialisation_Data (Start .. Finish - 1));
+               Package_Name := Name_Find;
+               for Index in Package_First .. Package_Attributes.Last loop
+                  if Package_Name = Package_Attributes.Table (Index).Name then
+                     Write_Line ("Duplicate package name """ &
+                                 Initialisation_Data (Start .. Finish - 1) &
+                                 """ in Prj.Attr body.");
+                     raise Program_Error;
+                  end if;
+               end loop;
+
+               Is_An_Attribute := False;
+               Current_Attribute := Empty_Attribute;
+               Package_Attributes.Increment_Last;
+               Current_Package := Package_Attributes.Last;
+               Package_Attributes.Table (Current_Package).Name :=
+                 Package_Name;
+               Start := Finish + 1;
+            when 'S' =>
+               Kind_1 := Single;
+            when 'L' =>
+               Kind_1 := List;
+            when others =>
+               raise Program_Error;
+         end case;
+
+         if Is_An_Attribute then
+            --  New attribute
+            Start := Start + 1;
+            case Initialisation_Data (Start) is
+               when 'V' =>
+                  Kind_2 := Single;
+               when 'A' =>
+                  Kind_2 := Associative_Array;
+               when 'B' =>
+                  Kind_2 := Both;
+               when others =>
+                  raise Program_Error;
+            end case;
+            Start := Start + 1;
+            Finish := Start;
+            while Initialisation_Data (Finish) /= '#' loop
+               Finish := Finish + 1;
+            end loop;
+            Name_Len := Finish - Start;
+            Name_Buffer (1 .. Name_Len) :=
+              To_Lower (Initialisation_Data (Start .. Finish - 1));
+            Attribute_Name := Name_Find;
+            Attributes.Increment_Last;
+            if Current_Attribute = Empty_Attribute then
+               First_Attribute := Attributes.Last;
+               if Current_Package /= Empty_Package then
+                  Package_Attributes.Table (Current_Package).First_Attribute
+                    := Attributes.Last;
+               end if;
+            else
+               --  Check that there are no duplicate attributes
+               for Index in First_Attribute .. Attributes.Last - 1 loop
+                  if Attribute_Name =
+                    Attributes.Table (Index).Name then
+                     Write_Line ("Duplicate attribute name """ &
+                                 Initialisation_Data (Start .. Finish - 1) &
+                                 """ in Prj.Attr body.");
+                     raise Program_Error;
+                  end if;
+               end loop;
+               Attributes.Table (Current_Attribute).Next :=
+                 Attributes.Last;
+            end if;
+            Current_Attribute := Attributes.Last;
+            Attributes.Table (Current_Attribute) :=
+              (Name    => Attribute_Name,
+               Kind_1  => Kind_1,
+               Kind_2  => Kind_2,
+               Next    => Empty_Attribute);
+            Start := Finish + 1;
+         end if;
+      end loop;
+   end Initialize;
+
+end Prj.Attr;

gcc/ada/prj-attr.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . A T T R                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.1 $
+--                                                                          --
+--             Copyright (C) 2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  This package defines allowed packages and attributes in GNAT project
+--  files.
+
+with Types; use Types;
+with Table;
+
+package Prj.Attr is
+
+   --  Define the allowed attributes
+
+   Attributes_Initial   : constant := 50;
+   Attributes_Increment : constant := 50;
+
+   Attribute_Node_Low_Bound  : constant := 0;
+   Attribute_Node_High_Bound : constant := 099_999_999;
+
+   type Attribute_Node_Id is
+     range Attribute_Node_Low_Bound .. Attribute_Node_High_Bound;
+
+   First_Attribute_Node_Id : constant Attribute_Node_Id
+     := Attribute_Node_Low_Bound;
+
+   Empty_Attribute : constant Attribute_Node_Id
+     := Attribute_Node_Low_Bound;
+
+   type Attribute_Kind is (Single, Associative_Array, Both);
+
+   type Attribute_Record is record
+      Name     : Name_Id;
+      Kind_1   : Variable_Kind;
+      Kind_2   : Attribute_Kind;
+      Next     : Attribute_Node_Id;
+   end record;
+
+   package Attributes is
+      new Table.Table (Table_Component_Type => Attribute_Record,
+                       Table_Index_Type     => Attribute_Node_Id,
+                       Table_Low_Bound      => First_Attribute_Node_Id,
+                       Table_Initial        => Attributes_Initial,
+                       Table_Increment      => Attributes_Increment,
+                       Table_Name           => "Prj.Attr.Attributes");
+
+   Attribute_First : constant Attribute_Node_Id := First_Attribute_Node_Id + 1;
+
+   --  Define the allowed packages
+
+   Packages_Initial   : constant := 10;
+   Packages_Increment : constant := 10;
+
+   Package_Node_Low_Bound  : constant := 0;
+   Package_Node_High_Bound : constant := 099_999_999;
+
+   type Package_Node_Id is
+     range Package_Node_Low_Bound .. Package_Node_High_Bound;
+
+   First_Package_Node_Id : constant Package_Node_Id
+     := Package_Node_Low_Bound;
+
+   Empty_Package : constant Package_Node_Id := Package_Node_Low_Bound;
+
+   type Package_Record is record
+      Name            : Name_Id;
+      First_Attribute : Attribute_Node_Id;
+   end record;
+
+   package Package_Attributes is
+      new Table.Table (Table_Component_Type => Package_Record,
+                       Table_Index_Type     => Package_Node_Id,
+                       Table_Low_Bound      => First_Package_Node_Id,
+                       Table_Initial        => Packages_Initial,
+                       Table_Increment      => Packages_Increment,
+                       Table_Name           => "Prj.Attr.Packages");
+
+   Package_First : constant Package_Node_Id := Package_Node_Low_Bound + 1;
+
+   procedure Initialize;
+   --  Initialize the two tables above (Attributes and Package_Attributes).
+   --  This procedure should be called by Prj.Initialize.
+
+end Prj.Attr;

gcc/ada/prj-com.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . C O M                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.1 $
+--                                                                          --
+--             Copyright (C) 2000 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Namet;   use Namet;
+with Stringt; use Stringt;
+
+package body Prj.Com is
+
+   ----------
+   -- Hash --
+   ----------
+
+   function Hash (Name : Name_Id) return Header_Num is
+   begin
+      return Hash (Get_Name_String (Name));
+   end Hash;
+
+   function Hash (Name : String_Id) return Header_Num is
+   begin
+      String_To_Name_Buffer (Name);
+      return Hash (Name_Buffer (1 .. Name_Len));
+   end Hash;
+
+end Prj.Com;

gcc/ada/prj-com.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . C O M                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $                              --
+--                                                                          --
+--          Copyright (C) 1992-2000 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  The following package declares data types for GNAT project.
+--  These data types are used in the bodies of the Prj hierarchy.
+
+with GNAT.HTable;
+with Table;
+with Types; use Types;
+
+package Prj.Com is
+
+   --  At one point, this package was private.
+   --  It cannot be private, because it is used outside of
+   --  the Prj hierarchy.
+
+   Tool_Name : Name_Id := No_Name;
+
+   Current_Verbosity : Verbosity := Default;
+
+   type Spec_Or_Body is
+     (Specification, Body_Part);
+
+   type File_Name_Data is record
+      Name         : Name_Id := No_Name;
+      Path         : Name_Id := No_Name;
+      Project      : Project_Id := No_Project;
+      Needs_Pragma : Boolean := False;
+   end record;
+   --  File and Path name of a spec or body.
+
+   type File_Names_Data is array (Spec_Or_Body) of File_Name_Data;
+
+   type Unit_Id is new Nat;
+   No_Unit : constant Unit_Id := 0;
+   type Unit_Data is record
+      Name       : Name_Id    := No_Name;
+      File_Names : File_Names_Data;
+   end record;
+   --  File and Path names of a unit, with a reference to its
+   --  GNAT Project File.
+
+   package Units is new Table.Table
+     (Table_Component_Type => Unit_Data,
+      Table_Index_Type     => Unit_Id,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 100,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.Com.Units");
+
+   type Header_Num is range 0 .. 2047;
+
+   function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
+
+   function Hash (Name : Name_Id) return Header_Num;
+
+   function Hash (Name : String_Id) return Header_Num;
+
+   package Units_Htable is new GNAT.HTable.Simple_HTable
+     (Header_Num => Header_Num,
+      Element    => Unit_Id,
+      No_Element => No_Unit,
+      Key        => Name_Id,
+      Hash       => Hash,
+      Equal      => "=");
+
+end Prj.Com;

gcc/ada/prj-dect.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . D E C T                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.2 $
+--                                                                          --
+--             Copyright (C) 2000 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Parse a list of declarative items in a project file.
+
+with Prj.Tree;
+
+private package Prj.Dect is
+
+   procedure Parse
+     (Declarations    : out Prj.Tree.Project_Node_Id;
+      Current_Project : Prj.Tree.Project_Node_Id;
+      Modifying       : Prj.Tree.Project_Node_Id);
+   --  Parse project declarative items.
+
+end Prj.Dect;

gcc/ada/prj-env.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . E N V                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.10 $
+--                                                                          --
+--             Copyright (C) 2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package implements services for Project-aware tools, related
+--  to the environment (gnat.adc, ADA_INCLUDE_PATH, ADA_OBJECTS_PATH)
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+package Prj.Env is
+
+   procedure Initialize;
+   --  Put Standard_Naming_Data into Namings table (called by Prj.Initialize)
+
+   procedure Print_Sources;
+   --  Output the list of sources, after Project files have been scanned
+
+   procedure Create_Config_Pragmas_File
+     (For_Project  : Project_Id;
+      Main_Project : Project_Id);
+   --  If there needs to have SFN pragmas, either for non standard naming
+   --  schemes or for individual units, or if Global_Configuration_Pragmas
+   --  has been specified in package gnatmake of the main project, or if
+   --  Local_Configuration_Pragmas has been specified in package Compiler
+   --  of the main project, build (if needed) a temporary file that contains
+   --  all configuration pragmas, and specify the configuration pragmas file
+   --  in the project data.
+
+   function Ada_Include_Path (Project : Project_Id) return String_Access;
+   --  Get the ADA_INCLUDE_PATH of a Project file. For the first call, compute
+   --  it and cache it.
+
+   function Ada_Objects_Path
+     (Project             : Project_Id;
+      Including_Libraries : Boolean := True)
+      return                String_Access;
+   --  Get the ADA_OBJECTS_PATH of a Project file. For the first call, compute
+   --  it and cache it. When Including_Libraries is False, do not include the
+   --  object directories of the library projects, and do not cache the result.
+
+   function Path_Name_Of_Library_Unit_Body
+     (Name    : String;
+      Project : Project_Id)
+      return    String;
+   --  Returns the Path of a library unit.
+
+   function File_Name_Of_Library_Unit_Body
+     (Name    : String;
+      Project : Project_Id)
+      return    String;
+   --  Returns the file name of a library unit, in canonical case. Name may or
+   --  may not have an extension (corresponding to the naming scheme of the
+   --  project). If there is no body with this name, but there is a spec, the
+   --  name of the spec is returned. If neither a body or a spec can be found,
+   --  return an empty string.
+
+   procedure Get_Reference
+     (Source_File_Name : String;
+      Project          : out Project_Id;
+      Path             : out Name_Id);
+   --  Returns the project of a source.
+
+   generic
+      with procedure Action (Path : String);
+   procedure For_All_Source_Dirs (Project : Project_Id);
+   --  Iterate through all the source directories of a project,
+   --  including those of imported or modified projects.
+
+   generic
+      with procedure Action (Path : String);
+   procedure For_All_Object_Dirs (Project : Project_Id);
+   --  Iterate through all the object directories of a project,
+   --  including those of imported or modified projects.
+
+end Prj.Env;

gcc/ada/prj-ext.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . E X T                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.5 $
+--                                                                          --
+--             Copyright (C) 2000 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with GNAT.HTable;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Namet;       use Namet;
+with Prj.Com;     use Prj.Com;
+with Stringt;     use Stringt;
+with Types;       use Types;
+
+package body Prj.Ext is
+
+   package Htable is new GNAT.HTable.Simple_HTable
+     (Header_Num => Header_Num,
+      Element    => String_Id,
+      No_Element => No_String,
+      Key        => Name_Id,
+      Hash       => Hash,
+      Equal      => "=");
+
+   ---------
+   -- Add --
+   ---------
+
+   procedure Add
+     (External_Name : String;
+      Value         : String)
+   is
+      The_Key   : Name_Id;
+      The_Value : String_Id;
+
+   begin
+      Start_String;
+      Store_String_Chars (Value);
+      The_Value := End_String;
+      Name_Len := External_Name'Length;
+      Name_Buffer (1 .. Name_Len) := External_Name;
+      The_Key := Name_Find;
+      Htable.Set (The_Key, The_Value);
+   end Add;
+
+   -----------
+   -- Check --
+   -----------
+
+   function Check (Declaration : String) return Boolean is
+   begin
+      for Equal_Pos in Declaration'Range loop
+
+         if Declaration (Equal_Pos) = '=' then
+            exit when Equal_Pos = Declaration'First;
+            exit when Equal_Pos = Declaration'Last;
+            Add
+              (External_Name =>
+                 Declaration (Declaration'First .. Equal_Pos - 1),
+               Value =>
+                 Declaration (Equal_Pos + 1 .. Declaration'Last));
+            return True;
+         end if;
+
+      end loop;
+
+      return False;
+   end Check;
+
+   --------------
+   -- Value_Of --
+   --------------
+
+   function Value_Of
+     (External_Name : Name_Id;
+      With_Default  : String_Id := No_String)
+      return          String_Id
+   is
+      The_Value : String_Id;
+
+   begin
+      The_Value := Htable.Get (External_Name);
+
+      if The_Value /= No_String then
+         return The_Value;
+      end if;
+
+      --  Find if it is an environment.
+      --  If it is, put the value in the hash table.
+
+      declare
+         Env_Value : constant String_Access :=
+           Getenv (Get_Name_String (External_Name));
+
+      begin
+         if Env_Value /= null and then Env_Value'Length > 0 then
+            Start_String;
+            Store_String_Chars (Env_Value.all);
+            The_Value := End_String;
+            Htable.Set (External_Name, The_Value);
+            return The_Value;
+
+         else
+            return With_Default;
+         end if;
+      end;
+   end Value_Of;
+
+end Prj.Ext;

gcc/ada/prj-ext.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . E X T                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $
+--                                                                          --
+--             Copyright (C) 2000 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Set, Get and cache External reference, to be used as External functions
+--  in project files.
+
+with Types; use Types;
+
+package Prj.Ext is
+
+   procedure Add
+     (External_Name : String;
+      Value         : String);
+   --  Add an external reference (or modify an existing one).
+
+   function Value_Of
+     (External_Name : Name_Id;
+      With_Default  : String_Id := No_String)
+      return          String_Id;
+   --  Get the value of an external reference, and cache it for future uses.
+
+   function Check (Declaration : String) return Boolean;
+   --  Check that an external declaration <external>=<value> is correct.
+   --  If it is correct, the external reference is Added.
+
+end Prj.Ext;

gcc/ada/prj-nmsc.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P R J . N M S C                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $
+--                                                                          --
+--             Copyright (C) 2000-2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Check the Naming Scheme of a project file, find the directories
+--  and the source files.
+
+private package Prj.Nmsc is
+
+   procedure Check_Naming_Scheme
+     (Project      : Project_Id;
+      Report_Error : Put_Line_Access);
+   --  Check that the Naming Scheme of a project is legal. Find the
+   --  object directory, the source directories, and the source files.
+   --  Check the source files against the Naming Scheme.
+   --  If Report_Error is null , use the standard error reporting mechanism
+   --  (Errout). Otherwise, report errors using Report_Error.
+
+end Prj.Nmsc;

gcc/ada/prj-pars.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P R J . P A R S                             --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.19 $
+--                                                                          --
+--             Copyright (C) 2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions; use Ada.Exceptions;
+
+with Errout;   use Errout;
+with Output;   use Output;
+with Prj.Com;  use Prj.Com;
+with Prj.Part;
+with Prj.Proc;
+with Prj.Tree; use Prj.Tree;
+
+package body Prj.Pars is
+
+   -----------
+   -- Parse --
+   -----------
+
+   procedure Parse
+     (Project           : out Project_Id;
+      Project_File_Name : String)
+   is
+      Project_Tree      : Project_Node_Id := Empty_Node;
+      The_Project       : Project_Id      := No_Project;
+
+   begin
+      --  Parse the main project file into a tree
+
+      Prj.Part.Parse
+        (Project                => Project_Tree,
+         Project_File_Name      => Project_File_Name,
+         Always_Errout_Finalize => False);
+
+      --  If there were no error, process the tree
+
+      if Project_Tree /= Empty_Node then
+         Prj.Proc.Process
+           (Project           => The_Project,
+            From_Project_Node => Project_Tree,
+            Report_Error      => null);
+         Errout.Finalize;
+      end if;
+
+      Project := The_Project;
+
+   exception
+      when X : others =>
+
+         --  Internal error
+
+         Write_Line (Exception_Information (X));
+         Write_Str  ("Exception ");
+         Write_Str  (Exception_Name (X));
+         Write_Line (" raised, while processing project file");
+         Project := No_Project;
+   end Parse;
+
+   -------------------
+   -- Set_Verbosity --
+   -------------------
+
+   procedure Set_Verbosity (To : in Verbosity) is
+   begin
+      Current_Verbosity := To;
+   end Set_Verbosity;
+
+end Prj.Pars;

gcc/ada/prj-pars.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . P A R S                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.8 $
+--                                                                          --
+--          Copyright (C) 2000-2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Implements the parsing of project files.
+
+package Prj.Pars is
+
+   procedure Set_Verbosity (To : Verbosity);
+   --  Set the verbosity when parsing the project files.
+
+   procedure Parse
+     (Project           : out Project_Id;
+      Project_File_Name : String);
+   --  Parse a project files and all its imported project files.
+   --  If parsing is successful, Project_Id is the project ID
+   --  of the main project file; otherwise, Project_Id is set
+   --  to No_Project.
+
+end Prj.Pars;

gcc/ada/prj-part.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . P A R T                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $
+--                                                                          --
+--          Copyright (C) 2000-2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Implements the parsing of project files into a tree.
+
+with Prj.Tree;  use Prj.Tree;
+
+package Prj.Part is
+
+   procedure Parse
+     (Project                : out Project_Node_Id;
+      Project_File_Name      : String;
+      Always_Errout_Finalize : Boolean);
+   --  Parse a project file and all its imported project files
+   --  and create a tree.
+   --  Return the node for the project (or Empty_Node if parsing failed).
+   --  If Always_Errout_Finalize is True, Errout.Finalize is called
+   --  in all cases; otherwise, Errout.Finalize is only called if there are
+   --  errors (but not if there are only warnings).
+
+end Prj.Part;

gcc/ada/prj-proc.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . P R O C                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.2 $
+--                                                                          --
+--             Copyright (C) 2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  This package is used to convert a project file tree (see prj-tree.ads) to
+--  project file data structures (see prj.ads), taking into account
+--  the environment (external references).
+
+with Prj.Tree;  use Prj.Tree;
+
+package Prj.Proc is
+
+   procedure Process
+     (Project           : out Project_Id;
+      From_Project_Node : Project_Node_Id;
+      Report_Error      : Put_Line_Access);
+   --  Process a project file tree into project file data structures.
+   --  If Report_Error is null, use the standard error reporting mechanism
+   --  (Errout). Otherwise, report errors using Report_Error.
+
+end Prj.Proc;

gcc/ada/prj-strt.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P R J . S T R T                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.4 $
+--                                                                          --
+--             Copyright (C) 2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  This package implements parsing of string expressions in project files.
+
+with Prj.Tree;  use Prj.Tree;
+
+private package Prj.Strt is
+
+   procedure Parse_String_Type_List (First_String : out Project_Node_Id);
+   --  Get the list of literal strings that are allowed for a typed string.
+   --  On entry, the current token is the first literal string following
+   --  a left parenthesis in a string type declaration such as:
+   --    type Toto is ("string_1", "string_2", "string_3");
+   --  On exit, the current token is the right parenthesis.
+   --  The parameter First_String is a node that contained the first
+   --  literal string of the string type, linked with the following
+   --  literal strings.
+   --
+   --  Report an error if
+   --    - a literal string is not found at the beginning of the list
+   --      or after a comma
+   --    - two literal strings in the list are equal
+
+   procedure Start_New_Case_Construction (String_Type : Project_Node_Id);
+   --  This procedure is called at the beginning of a case construction
+   --  The parameter String_Type is the node for the string type
+   --  of the case label variable.
+   --  The different literal strings of the string type are stored
+   --  into a table to be checked against the case labels of the
+   --  case construction.
+
+   procedure End_Case_Construction;
+   --  This procedure is called at the end of a case construction
+   --  to remove the case labels and to restore the previous state.
+   --  In particular, in the case of nested case constructions,
+   --  the case labels of the enclosing case construction are restored.
+
+   procedure Parse_Choice_List
+     (First_Choice : out Project_Node_Id);
+   --  Get the label for a choice list.
+   --  Report an error if
+   --    - a case label is not a literal string
+   --    - a case label is not in the typed string list
+   --    - the same case label is repeated in the same case construction
+
+   procedure Parse_Expression
+     (Expression      : out Project_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id);
+   --  Parse a simple string expression or a string list expression.
+   --  Current_Project is the node of the project file being parsed.
+   --  Current_Package is the node of the package being parsed,
+   --  or Empty_Node when we are at the project level (not in a package).
+   --  On exit, Expression is the node of the expression that has
+   --  been parsed.
+
+   procedure Parse_Variable_Reference
+     (Variable        : out Project_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id);
+   --  Parse a variable or attribute reference.
+   --  Used internally (in expressions) and for case variables (in Prj.Dect).
+   --  Current_Package is the node of the package being parsed,
+   --  or Empty_Node when we are at the project level (not in a package).
+   --  On exit, Variable is the node of the variable or attribute reference.
+   --  A variable reference is made of one to three simple names.
+   --  An attribute reference is made of one or two simple names,
+   --  followed by an apostroph, followed by the attribute simple name.
+
+end Prj.Strt;

gcc/ada/prj-util.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . U T I L                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.6 $
+--                                                                          --
+--             Copyright (C) 2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Utilities when using project files.
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Types;       use Types;
+
+package Prj.Util is
+
+   function Value_Of
+     (Index    : Name_Id;
+      In_Array : Array_Element_Id)
+      return     Name_Id;
+   --  Get a single string array component.
+   --  Returns No_Name if there is no component Index (case sensitive),
+   --  if In_Array is null, or if the component is a String list.
+
+   function Value_Of
+     (Index    : Name_Id;
+      In_Array : Array_Element_Id)
+      return     Variable_Value;
+   --  Get a string array component (single String or String list).
+   --  Returns Nil_Variable_Value if there is no component Index
+   --  (case sensitive), or if In_Array is null.
+
+   function Value_Of
+     (Name                    : Name_Id;
+      Attribute_Or_Array_Name : Name_Id;
+      In_Package              : Package_Id)
+      return                   Variable_Value;
+   --  In a specific package,
+   --   - if there exists an array Variable_Or_Array_Name with an index
+   --     Name, returns the corresponding component,
+   --   - otherwise if there is a attribute Attribute_Or_Array_Name,
+   --     returns this attribute,
+   --   - otherwise, returns Nil_Variable_Value.
+   --  If In_Package is null, returns Nil_Variable_Value.
+
+   function Value_Of
+     (Index     : Name_Id;
+      In_Array  : Name_Id;
+      In_Arrays : Array_Id)
+      return      Name_Id;
+   --  Get a string array component in an array of an array list.
+   --  Returns No_Name if there is no component Index (case sensitive),
+   --  if In_Arrays is null, if In_Array is not found in In_Arrays,
+   --  or if the component is a String list.
+
+   function Value_Of
+     (Name      : Name_Id;
+      In_Arrays : Array_Id)
+      return      Array_Element_Id;
+   --  Returns a specified array in an array list.
+   --  Returns No_Array_Element if In_Arrays is null or if Name is not the
+   --  name of an array in In_Arrays.
+   --  Assumption: Name is in lower case.
+
+   function Value_Of
+     (Name        : Name_Id;
+      In_Packages : Package_Id)
+      return        Package_Id;
+   --  Returns a specified package in a package list.
+   --  Returns No_Package if In_Packages is null or if Name is not the
+   --  name of a package in Package_List.
+   --  Assumption: Name is in lower case.
+
+   function Value_Of
+     (Variable_Name : Name_Id;
+      In_Variables  : Variable_Id)
+      return          Variable_Value;
+   --  Returns a specified variable in a variable list.
+   --  Returns null if In_Variables is null or if Variable_Name
+   --  is not the name of a variable in In_Variables.
+   --  Assumption: Variable_Name is in lower case.
+
+   procedure Write_Str
+     (S          : String;
+      Max_Length : Positive;
+      Separator  : Character);
+   --  Output string S using Output.Write_Str.
+   --  If S is too long to fit in one line of Max_Length, cut it in
+   --  several lines, using Separator as the last character of each line,
+   --  if possible.
+
+   type Text_File is limited private;
+   --  Represents a text file.
+   --  Default is invalid text file.
+
+   function Is_Valid (File : Text_File) return Boolean;
+   --  Returns True if File designates an open text file that
+   --  has not yet been closed.
+
+   procedure Open (File : out Text_File; Name : String);
+   --  Open a text file. If this procedure fails, File is invalid.
+
+   function End_Of_File (File : Text_File) return Boolean;
+   --  Returns True if the end of the text file File has been
+   --  reached. Fails if File is invalid.
+
+   procedure Get_Line
+     (File : Text_File;
+      Line : out String;
+      Last : out Natural);
+   --  Reads a line from an open text file. Fails if File is invalid.
+
+   procedure Close (File : in out Text_File);
+   --  Close an open text file. File becomes invalid.
+   --  Fails if File is already invalid.
+
+private
+
+   type Text_File_Data is record
+      FD                  : File_Descriptor := Invalid_FD;
+      Buffer              : String (1 .. 1_000);
+      Buffer_Len          : Natural;
+      Cursor              : Natural := 0;
+      End_Of_File_Reached : Boolean := False;
+   end record;
+
+   type Text_File is access Text_File_Data;
+
+end Prj.Util;

gcc/ada/prj.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                  P R J                                   --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.16 $
+--                                                                          --
+--             Copyright (C) 2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Errout;      use Errout;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Namet;       use Namet;
+with Osint;       use Osint;
+with Prj.Attr;
+with Prj.Com;
+with Prj.Env;
+with Scans;       use Scans;
+with Scn;
+with Stringt;     use Stringt;
+with Sinfo.CN;
+with Snames;      use Snames;
+
+package body Prj is
+
+   The_Empty_String : String_Id;
+
+   subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
+
+   The_Casing_Images : array (Known_Casing) of String_Access :=
+     (All_Lower_Case => new String'("lowercase"),
+      All_Upper_Case => new String'("UPPERCASE"),
+      Mixed_Case     => new String'("MixedCase"));
+
+   Initialized : Boolean := False;
+
+   Standard_Dot_Replacement      : constant Name_Id :=
+     First_Name_Id + Character'Pos ('-');
+   Standard_Specification_Append : Name_Id;
+   Standard_Body_Append          : Name_Id;
+
+   Std_Naming_Data : Naming_Data :=
+     (Dot_Replacement      => Standard_Dot_Replacement,
+      Dot_Repl_Loc         => No_Location,
+      Casing               => All_Lower_Case,
+      Specification_Append => No_Name,
+      Spec_Append_Loc      => No_Location,
+      Body_Append          => No_Name,
+      Body_Append_Loc      => No_Location,
+      Separate_Append      => No_Name,
+      Sep_Append_Loc       => No_Location,
+      Specifications       => No_Array_Element,
+      Bodies               => No_Array_Element);
+
+   Project_Empty : Project_Data :=
+     (First_Referred_By  => No_Project,
+      Name               => No_Name,
+      Path_Name          => No_Name,
+      Location           => No_Location,
+      Directory          => No_Name,
+      File_Name          => No_Name,
+      Library            => False,
+      Library_Dir        => No_Name,
+      Library_Name       => No_Name,
+      Library_Kind       => Static,
+      Lib_Internal_Name  => No_Name,
+      Lib_Elaboration    => False,
+      Sources            => Nil_String,
+      Source_Dirs        => Nil_String,
+      Object_Directory   => No_Name,
+      Modifies           => No_Project,
+      Modified_By        => No_Project,
+      Naming             => Std_Naming_Data,
+      Decl               => No_Declarations,
+      Imported_Projects  => Empty_Project_List,
+      Include_Path       => null,
+      Objects_Path       => null,
+      Config_File_Name   => No_Name,
+      Config_File_Temp   => False,
+      Config_Checked     => False,
+      Checked            => False,
+      Seen               => False,
+      Flag1              => False,
+      Flag2              => False);
+
+   -------------------
+   -- Empty_Project --
+   -------------------
+
+   function Empty_Project return Project_Data is
+   begin
+      Initialize;
+      return Project_Empty;
+   end Empty_Project;
+
+   ------------------
+   -- Empty_String --
+   ------------------
+
+   function Empty_String return String_Id is
+   begin
+      return The_Empty_String;
+   end Empty_String;
+
+   ------------
+   -- Expect --
+   ------------
+
+   procedure Expect (The_Token : Token_Type; Token_Image : String) is
+   begin
+      if Token /= The_Token then
+         Error_Msg ("""" & Token_Image & """ expected", Token_Ptr);
+      end if;
+   end Expect;
+
+   --------------------------------
+   -- For_Every_Project_Imported --
+   --------------------------------
+
+   procedure For_Every_Project_Imported
+     (By         : Project_Id;
+      With_State : in out State)
+   is
+
+      procedure Check (Project : Project_Id);
+      --  Check if a project has already been seen.
+      --  If not seen, mark it as seen, call Action,
+      --  and check all its imported projects.
+
+      procedure Check (Project : Project_Id) is
+         List : Project_List;
+
+      begin
+         if not Projects.Table (Project).Seen then
+            Projects.Table (Project).Seen := False;
+            Action (Project, With_State);
+
+            List := Projects.Table (Project).Imported_Projects;
+            while List /= Empty_Project_List loop
+               Check (Project_Lists.Table (List).Project);
+               List := Project_Lists.Table (List).Next;
+            end loop;
+         end if;
+      end Check;
+
+   begin
+      for Project in Projects.First .. Projects.Last loop
+         Projects.Table (Project).Seen := False;
+      end loop;
+
+      Check (Project => By);
+   end For_Every_Project_Imported;
+
+   -----------
+   -- Image --
+   -----------
+
+   function Image (Casing : Casing_Type) return String is
+   begin
+      return The_Casing_Images (Casing).all;
+   end Image;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      if not Initialized then
+         Initialized := True;
+         Stringt.Initialize;
+         Start_String;
+         The_Empty_String := End_String;
+         Name_Len := 4;
+         Name_Buffer (1 .. 4) := ".ads";
+         Canonical_Case_File_Name (Name_Buffer (1 .. 4));
+         Standard_Specification_Append := Name_Find;
+         Name_Buffer (4) := 'b';
+         Canonical_Case_File_Name (Name_Buffer (1 .. 4));
+         Standard_Body_Append := Name_Find;
+         Std_Naming_Data.Specification_Append := Standard_Specification_Append;
+         Std_Naming_Data.Body_Append          := Standard_Body_Append;
+         Std_Naming_Data.Separate_Append      := Standard_Body_Append;
+         Project_Empty.Naming                 := Std_Naming_Data;
+         Prj.Env.Initialize;
+         Prj.Attr.Initialize;
+         Set_Name_Table_Byte (Name_Project,   Token_Type'Pos (Tok_Project));
+         Set_Name_Table_Byte (Name_Modifying, Token_Type'Pos (Tok_Modifying));
+         Set_Name_Table_Byte (Name_External,  Token_Type'Pos (Tok_External));
+      end if;
+   end Initialize;
+
+   ------------
+   --  Reset --
+   ------------
+
+   procedure Reset is
+   begin
+      Projects.Init;
+      Project_Lists.Init;
+      Packages.Init;
+      Arrays.Init;
+      Variable_Elements.Init;
+      String_Elements.Init;
+      Prj.Com.Units.Init;
+      Prj.Com.Units_Htable.Reset;
+   end Reset;
+
+   ------------------------
+   -- Same_Naming_Scheme --
+   ------------------------
+
+   function Same_Naming_Scheme
+     (Left, Right : Naming_Data)
+      return        Boolean
+   is
+   begin
+      return Left.Dot_Replacement = Right.Dot_Replacement
+        and then Left.Casing = Right.Casing
+        and then Left.Specification_Append = Right.Specification_Append
+        and then Left.Body_Append = Right.Body_Append
+        and then Left.Separate_Append = Right.Separate_Append;
+   end Same_Naming_Scheme;
+
+   ----------
+   -- Scan --
+   ----------
+
+   procedure Scan is
+   begin
+      Scn.Scan;
+
+      --  Change operator symbol to literal strings, since that's the way
+      --  we treat all strings in a project file.
+
+      if Token = Tok_Operator_Symbol then
+         Sinfo.CN.Change_Operator_Symbol_To_String_Literal (Token_Node);
+         Token := Tok_String_Literal;
+      end if;
+   end Scan;
+
+   --------------------------
+   -- Standard_Naming_Data --
+   --------------------------
+
+   function Standard_Naming_Data return Naming_Data is
+   begin
+      Initialize;
+      return Std_Naming_Data;
+   end Standard_Naming_Data;
+
+   -----------
+   -- Value --
+   -----------
+
+   function Value (Image : String) return Casing_Type is
+   begin
+      for Casing in The_Casing_Images'Range loop
+         if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
+            return Casing;
+         end if;
+      end loop;
+
+      raise Constraint_Error;
+   end Value;
+
+end Prj;

gcc/ada/raise.c

+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                                R A I S E                                 *
+ *                                                                          *
+ *                          C Implementation File                           *
+ *                                                                          *
+ *                            $Revision: 1.1 $
+ *                                                                          *
+ *             Copyright (C) 1992-2001, 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 2,  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 COPYING.  If not, write *
+ * to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, *
+ * MA 02111-1307, USA.                                                      *
+ *                                                                          *
+ * As a  special  exception,  if you  link  this file  with other  files to *
+ * produce an executable,  this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not  however invalidate  any other reasons  why the  executable *
+ * file might be covered by the  GNU Public License.                        *
+ *                                                                          *
+ * GNAT was originally developed  by the GNAT team at  New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ *                                                                          *
+ ****************************************************************************/
+
+/* Routines to support runtime exception handling */
+
+#ifdef IN_RTS
+#include "tconfig.h"
+#include "tsystem.h"
+#include <sys/stat.h>
+#else
+#include "config.h"
+#include "system.h"
+#endif
+
+#include "adaint.h"
+#include "raise.h"
+
+/*  We have not yet figured out how to import this directly */
+
+void
+_gnat_builtin_longjmp (ptr, flag)
+     void *ptr;
+     int flag ATTRIBUTE_UNUSED;
+{
+   __builtin_longjmp (ptr, 1);
+}
+
+/* When an exception is raised for which no handler exists, the procedure
+   Ada.Exceptions.Unhandled_Exception is called, which performs the call to
+   adafinal to complete finalization, and then prints out the error messages
+   for the unhandled exception. The final step is to call this routine, which
+   performs any system dependent cleanup required.  */
+
+void
+__gnat_unhandled_terminate ()
+{
+  /* Special termination handling for VMS */
+
+#ifdef VMS
+    {
+      long prvhnd;
+
+      /* Remove the exception vector so it won't intercept any errors
+	 in the call to exit, and go into and endless loop */
+
+      SYS$SETEXV (1, 0, 3, &prvhnd);
+      __gnat_os_exit (1);
+    }
+
+/* Termination handling for all other systems. */
+
+#elif !defined (__RT__)
+    __gnat_os_exit (1);
+#endif
+}

gcc/ada/raise.h

+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                                R A I S E                                 *
+ *                                                                          *
+ *                              C Header File                               *
+ *                                                                          *
+ *                            $Revision: 1.1 $
+ *                                                                          *
+ *          Copyright (C) 1992-2001, 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 2,  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 COPYING.  If not, write *
+ * to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, *
+ * MA 02111-1307, USA.                                                      *
+ *                                                                          *
+ * As a  special  exception,  if you  link  this file  with other  files to *
+ * produce an executable,  this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not  however invalidate  any other reasons  why the  executable *
+ * file might be covered by the  GNU Public License.                        *
+ *                                                                          *
+ * GNAT was originally developed  by the GNAT team at  New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ *                                                                          *
+ ****************************************************************************/
+
+struct Exception_Data
+{ 
+  char  Handled_By_Others;
+  char Lang;
+  int Name_Length;
+  char *Full_Name, Htable_Ptr;
+  int Import_Code;
+};
+
+typedef struct Exception_Data *Exception_Id;
+
+struct Exception_Occurrence
+{
+  int Max_Length;
+  Exception_Id Id;
+  int Msg_Length;
+  char Msg [0];
+};
+
+typedef struct Exception_Occurrence *Exception_Occurrence_Access;
+
+extern void _gnat_builtin_longjmp	PARAMS ((void *, int));
+extern void __gnat_unhandled_terminate	PARAMS ((void));
+extern void *__gnat_malloc		PARAMS ((__SIZE_TYPE__));
+extern void __gnat_free			PARAMS ((void *));
+extern void *__gnat_realloc		PARAMS ((void *, __SIZE_TYPE__));
+extern void __gnat_finalize		PARAMS ((void));
+extern void set_gnat_exit_status	PARAMS ((int));
+extern void __gnat_set_globals		PARAMS ((int, int, int, int, int, int,
+						 void (*) PARAMS ((void)),
+						 int, int));
+extern void __gnat_initialize		PARAMS ((void));
+extern void __gnat_init_float		PARAMS ((void));
+extern void __gnat_install_handler	PARAMS ((void));
+
+extern int gnat_exit_status;
+

gcc/ada/repinfo.h

+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                              R E P I N F O                               *
+ *                                                                          *
+ *                              C Header File                               *
+ *                                                                          *
+ *                             $Revision: 1.1 $
+ *                                                                          *
+ *          Copyright (C) 1999-2001 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 2,  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 COPYING.  If not, write *
+ * to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, *
+ * MA 02111-1307, USA.                                                      *
+ *                                                                          *
+ * As a  special  exception,  if you  link  this file  with other  files to *
+ * produce an executable,  this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not  however invalidate  any other reasons  why the  executable *
+ * file might be covered by the  GNU Public License.                        *
+ *                                                                          *
+ * GNAT was originally developed  by the GNAT team at  New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ *                                                                          *
+ ****************************************************************************/
+
+/* This file corresponds to the Ada file repinfo.ads.  */
+
+typedef Uint Node_Ref;
+typedef Uint Node_Ref_Or_Val;
+typedef char TCode;
+
+/* These are the values of TCcode that correspond to tree codes in tree.def,
+   except for the first, which is how we encode discriminants.  */
+
+#define Discrim_Val       0
+#define Cond_Expr         1
+#define Plus_Expr         2
+#define Minus_Expr        3
+#define Mult_Expr         4
+#define Trunc_Div_Expr    5
+#define Ceil_Div_Expr     6
+#define Floor_Div_Expr    7
+#define Trunc_Mod_Expr    8
+#define Ceil_Mod_Expr     9
+#define Floor_Mod_Expr   10
+#define Exact_Div_Expr   11
+#define Negate_Expr      12
+#define Min_Expr         13
+#define Max_Expr         14
+#define Abs_Expr         15
+#define Truth_Andif_Expr 16
+#define Truth_Orif_Expr  17
+#define Truth_And_Expr   18
+#define Truth_Or_Expr    19
+#define Truth_Xor_Expr   20
+#define Truth_Not_Expr   21
+#define Lt_Expr          22
+#define Le_Expr          23
+#define Gt_Expr          24
+#define Ge_Expr          25
+#define Eq_Expr          26
+#define Ne_Expr          27
+
+/* Creates a node using the tree code defined by Expr and from 1-3
+   operands as required (unused operands set as shown to No_Uint) Note
+   that this call can be used to create a discriminant reference by
+   using (Expr => Discrim_Val, Op1 => discriminant_number).  */
+#define Create_Node repinfo__create_node
+extern Node_Ref Create_Node	PARAMS((TCode, Node_Ref_Or_Val,
+					Node_Ref_Or_Val, Node_Ref_Or_Val));

gcc/ada/rident.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               R I D E N T                                --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.12 $
+--                                                                          --
+--          Copyright (C) 1992-2001 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 2,  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 COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package defines the set of restriction identifiers. It is in a
+--  separate package from Restrict so that it can be easily used by the
+--  binder without dragging in a lot of stuff.
+
+package Rident is
+
+   --  The following enumeration type defines the set of restriction
+   --  identifiers not taking a parameter that are implemented in GNAT.
+   --  To add a new restriction identifier, add an entry with the name
+   --  to be used in the pragma, and add appropriate calls to the
+   --  Check_Restriction routine.
+
+   type Restriction_Id is (
+
+      --  The following cases are checked for consistency in the binder
+
+      Boolean_Entry_Barriers,                  -- GNAT (Ravenscar)
+      No_Abort_Statements,                     -- (RM D.7(5), H.4(3))
+      No_Access_Subprograms,                   -- (RM H.4(17))
+      No_Allocators,                           -- (RM H.4(7))
+      No_Asynchronous_Control,                 -- (RM D.9(10))
+      No_Calendar,                             -- GNAT
+      No_Delay,                                -- (RM H.4(21))
+      No_Dispatch,                             -- (RM H.4(19))
+      No_Dynamic_Interrupts,                   -- GNAT
+      No_Dynamic_Priorities,                   -- (RM D.9(9))
+      No_Enumeration_Maps,                     -- GNAT
+      No_Entry_Calls_In_Elaboration_Code,      -- GNAT
+      No_Entry_Queue,                          -- GNAT
+      No_Exception_Handlers,                   -- GNAT
+      No_Exceptions,                           -- (RM H.4(12))
+      No_Fixed_Point,                          -- (RM H.4(15))
+      No_Floating_Point,                       -- (RM H.4(14))
+      No_IO,                                   -- (RM H.4(20))
+      No_Implicit_Conditionals,                -- GNAT
+      No_Implicit_Dynamic_Code,                -- GNAT
+      No_Implicit_Heap_Allocations,            -- (RM D.8(8), H.4(3))
+      No_Implicit_Loops,                       -- GNAT
+      No_Local_Allocators,                     -- (RM H.4(8))
+      No_Local_Protected_Objects,              -- GNAT
+      No_Nested_Finalization,                  -- (RM D.7(4))
+      No_Protected_Type_Allocators,            -- GNAT
+      No_Protected_Types,                      -- (RM H.4(5))
+      No_Recursion,                            -- (RM H.4(22))
+      No_Reentrancy,                           -- (RM H.4(23))
+      No_Relative_Delay,                       -- GNAT
+      No_Requeue,                              -- GNAT
+      No_Select_Statements,                    -- GNAT (Ravenscar)
+      No_Standard_Storage_Pools,               -- GNAT
+      No_Streams,                              -- GNAT
+      No_Task_Allocators,                      -- (RM D.7(7))
+      No_Task_Attributes,                      -- GNAT
+      No_Task_Hierarchy,                       -- (RM D.7(3), H.4(3))
+      No_Task_Termination,                     -- GNAT
+      No_Terminate_Alternatives,               -- (RM D.7(6))
+      No_Unchecked_Access,                     -- (RM H.4(18))
+      No_Unchecked_Conversion,                 -- (RM H.4(16))
+      No_Unchecked_Deallocation,               -- (RM H.4(9))
+      No_Wide_Characters,                      -- GNAT
+      Static_Priorities,                       -- GNAT
+      Static_Storage_Size,                     -- GNAT
+
+      --  The following cases do not require partition-wide checks
+
+      Immediate_Reclamation,                   -- (RM H.4(10))
+      No_Implementation_Attributes,            -- GNAT
+      No_Implementation_Pragmas,               -- GNAT
+      No_Implementation_Restrictions,          -- GNAT
+      No_Elaboration_Code,                     -- GNAT
+
+      Not_A_Restriction_Id);
+
+   --  The following range of Restriction identifiers is checked for
+   --  consistency across a partition. The generated ali file is marked
+   --  for each entry to show one of three possibilities:
+   --
+   --    Corresponding restriction is set (so unit does not violate it)
+   --    Corresponding restriction is not violated
+   --    Corresponding restriction is violated
+
+   subtype Partition_Restrictions is
+     Restriction_Id range Boolean_Entry_Barriers .. Static_Storage_Size;
+
+   --  The following set of Restriction identifiers is not checked for
+   --  consistency across a partition, and the generated ali files does
+   --  not carry any indications with respect to such restrictions.
+
+   subtype Compilation_Unit_Restrictions is
+     Restriction_Id range Immediate_Reclamation .. No_Elaboration_Code;
+
+   --  The following enumeration type defines the set of restriction
+   --  parameter identifiers taking a parameter that are implemented in
+   --  GNAT. To add a new restriction parameter identifier, add an entry
+   --  with the name to be used in the pragma, and add appropriate
+   --  calls to Check_Restriction.
+
+   --  Note: the GNAT implementation currently only accomodates restriction
+   --  parameter identifiers whose expression value is a non-negative
+   --  integer. This is true for all language defined parameters.
+
+   type Restriction_Parameter_Id is (
+     Max_Asynchronous_Select_Nesting,         -- (RM D.7(18), H.4(3))
+     Max_Entry_Queue_Depth,                   -- GNAT
+     Max_Protected_Entries,                   -- (RM D.7(14))
+     Max_Select_Alternatives,                 -- (RM D.7(12))
+     Max_Storage_At_Blocking,                 -- (RM D.7(17))
+     Max_Task_Entries,                        -- (RM D.7(13), H.4(3))
+     Max_Tasks,                               -- (RM D.7(19), H.4(3))
+     Not_A_Restriction_Parameter_Id);
+
+end Rident;